home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / srcuc.zip / LOOKUP.C < prev    next >
C/C++ Source or Header  |  1992-02-27  |  79KB  |  2,924 lines
  1. /* -*-C-*-
  2.  
  3. $Header: /scheme/src/microcode/RCS/lookup.c,v 9.51 1992/02/27 22:25:45 jinx Exp $
  4.  
  5. Copyright (c) 1988-1992 Massachusetts Institute of Technology
  6.  
  7. This material was developed by the Scheme project at the Massachusetts
  8. Institute of Technology, Department of Electrical Engineering and
  9. Computer Science.  Permission to copy this software, to redistribute
  10. it, and to use it for any purpose is granted, subject to the following
  11. restrictions and understandings.
  12.  
  13. 1. Any copy made of this software must include this copyright notice
  14. in full.
  15.  
  16. 2. Users of this software agree to make their best efforts (a) to
  17. return to the MIT Scheme project any improvements or extensions that
  18. they make, so that these may be included in future releases; and (b)
  19. to inform MIT of noteworthy uses of this software.
  20.  
  21. 3. All materials developed as a consequence of the use of this
  22. software shall duly acknowledge such use, in accordance with the usual
  23. standards of acknowledging credit in academic research.
  24.  
  25. 4. MIT has made no warrantee or representation that the operation of
  26. this software will be error-free, and MIT is under no obligation to
  27. provide any services, by way of maintenance, update, or otherwise.
  28.  
  29. 5. In conjunction with products arising from the use of this material,
  30. there shall be no use of the name of the Massachusetts Institute of
  31. Technology nor of any adaptation thereof in any advertising,
  32. promotional, or sales literature without prior written consent from
  33. MIT in each case. */
  34.  
  35. /*
  36.  * This file contains symbol lookup and modification routines.
  37.  * See a paper by Jim Miller and Bill Rozas in Lisp and Symbolic Computation
  38.  * (4th issue 1990) for a justification of the algorithms.
  39.  */
  40.  
  41. #include "scheme.h"
  42. #include "locks.h"
  43. #include "trap.h"
  44. #include "lookup.h"
  45.  
  46. /* NOTE:
  47.    Although this code has been parallelized, it has not been
  48.    exhaustively tried on a parallel processor.  There are probably
  49.    various race conditions/potential deadlocks that have to be thought
  50.    about carefully.
  51.  */
  52.  
  53. /* Useful constants. */
  54.  
  55. /* This is returned by various procedures to cause a Scheme
  56.    unbound variable error to be signalled.
  57.  */
  58.  
  59. SCHEME_OBJECT unbound_trap_object[] = { UNBOUND_OBJECT };
  60.  
  61. /* This is returned by lookup to force a deep lookup when the variable
  62.    needs to be recompiled.
  63.  */
  64.  
  65. SCHEME_OBJECT uncompiled_trap_object[] = { DANGEROUS_UNBOUND_OBJECT };
  66.  
  67. /* This is returned by lookup to cause a Scheme broken compiled
  68.    variable error to be signalled.
  69.  */
  70.  
  71. SCHEME_OBJECT illegal_trap_object[] = { ILLEGAL_OBJECT };
  72.  
  73. /* This is passed to deep_lookup as the variable to compile when
  74.    we don't really have a variable.
  75.  */
  76.  
  77. SCHEME_OBJECT fake_variable_object[3];
  78.  
  79. /* scan_frame searches a frame for a given name.
  80.    If it finds the names, it stores into hunk the path by which it was
  81.    found, so that future references do not spend the time to find it
  82.    again.  It returns a pointer to the value cell, or a null pointer
  83.    cell if the variable was not found in this frame.
  84.  */
  85.  
  86. extern SCHEME_OBJECT *
  87.   EXFUN (scan_frame,
  88.      (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *, long, Boolean));
  89.  
  90. SCHEME_OBJECT *
  91. DEFUN (scan_frame, (frame, sym, hunk, depth, unbound_valid_p),
  92.        SCHEME_OBJECT frame
  93.        AND SCHEME_OBJECT sym
  94.        AND SCHEME_OBJECT * hunk
  95.        AND long depth
  96.        AND Boolean unbound_valid_p)
  97. {
  98.   Lock_Handle compile_serializer;
  99.   fast SCHEME_OBJECT *scan, temp;
  100.   fast long count;
  101.  
  102.   temp = MEMORY_REF (frame, ENVIRONMENT_FUNCTION);
  103.  
  104.   if (OBJECT_TYPE (temp) == AUX_LIST_TYPE)
  105.   {
  106.     /* Search for an auxiliary binding. */
  107.  
  108.     SCHEME_OBJECT *start;
  109.  
  110.     scan = OBJECT_ADDRESS (temp);
  111.     start = scan;
  112.     count = Lexical_Offset(scan[AUX_LIST_COUNT]);
  113.     scan += AUX_LIST_FIRST;
  114.  
  115.     while (--count >= 0)
  116.     {
  117.       if (FAST_PAIR_CAR (*scan) == sym)
  118.       {
  119.     SCHEME_OBJECT *cell;
  120.  
  121.     cell = PAIR_CDR_LOC (*scan);
  122.     if (MEMORY_FETCH (cell[0]) == DANGEROUS_UNBOUND_OBJECT)
  123.     {
  124.       /* A dangerous unbound object signals that
  125.          a definition here must become dangerous,
  126.          but is not a real bining.
  127.        */
  128.       return (unbound_valid_p ? (cell) : ((SCHEME_OBJECT *) NULL));
  129.     }
  130.     setup_lock(compile_serializer, hunk);
  131.     hunk[VARIABLE_COMPILED_TYPE] = MAKE_OBJECT (AUX_REF, depth);
  132.     hunk[VARIABLE_OFFSET] = Make_Local_Offset(scan - start);
  133.     remove_lock(compile_serializer);
  134.     return (cell);
  135.       }
  136.       scan += 1;
  137.     }
  138.     temp = MEMORY_REF (temp, ENV_EXTENSION_PROCEDURE);
  139.   }
  140.  
  141.   /* Search for a formal parameter. */
  142.  
  143.   temp = (FAST_MEMORY_REF ((FAST_MEMORY_REF (temp, PROCEDURE_LAMBDA_EXPR)),
  144.                LAMBDA_FORMALS));
  145.   for (count = ((VECTOR_LENGTH (temp)) - 1),
  146.        scan = (MEMORY_LOC (temp, VECTOR_DATA + 1));
  147.        count > 0;
  148.        count -= 1,
  149.        scan += 1)
  150.   {
  151.     if (*scan == sym)
  152.     {
  153.       fast long offset;
  154.  
  155.       offset = 1 + VECTOR_LENGTH (temp) - count;
  156.  
  157.       setup_lock(compile_serializer, hunk);
  158.       if (depth != 0)
  159.       {
  160.     hunk[VARIABLE_COMPILED_TYPE] = MAKE_OBJECT (FORMAL_REF, depth);
  161.     hunk[VARIABLE_OFFSET] = Make_Local_Offset(offset);
  162.       }
  163.       else
  164.       {
  165.     hunk[VARIABLE_COMPILED_TYPE] = Make_Local_Offset(offset);
  166.     hunk[VARIABLE_OFFSET] = SHARP_F;
  167.       }
  168.       remove_lock(compile_serializer);
  169.  
  170.       return (MEMORY_LOC (frame, offset));
  171.     }
  172.   }
  173.  
  174.   return ((SCHEME_OBJECT *) NULL);
  175. }
  176.  
  177. /* The lexical lookup procedure.
  178.    deep_lookup searches env for an occurrence of sym.  When it finds
  179.    it, it stores into hunk the path by which it was found, so that
  180.    future references do not spend the time to find it again.
  181.    It returns a pointer to the value cell, or a bogus value cell if
  182.    the variable was unbound.
  183.  */
  184.  
  185. SCHEME_OBJECT *
  186. DEFUN (deep_lookup, (env, sym, hunk),
  187.        SCHEME_OBJECT env
  188.        AND SCHEME_OBJECT sym
  189.        AND SCHEME_OBJECT * hunk)
  190. {
  191.   Lock_Handle compile_serializer;
  192.   fast SCHEME_OBJECT frame;
  193.   fast long depth;
  194.  
  195.   for (depth = 0, frame = env;
  196.        OBJECT_TYPE (frame) != GLOBAL_ENV;
  197.        depth += 1,
  198.        frame = FAST_MEMORY_REF (MEMORY_REF (frame, ENVIRONMENT_FUNCTION),
  199.                    PROCEDURE_ENVIRONMENT))
  200.   {
  201.     fast SCHEME_OBJECT *cell;
  202.  
  203.     cell = (scan_frame (frame, sym, hunk, depth, false));
  204.     if (cell != ((SCHEME_OBJECT *) NULL))
  205.     {
  206.       return (cell);
  207.     }
  208.   }
  209.  
  210.   /* The reference is global. */
  211.  
  212.   if (OBJECT_DATUM (frame) != GO_TO_GLOBAL)
  213.   {
  214.     return (unbound_trap_object);
  215.   }
  216.  
  217.   setup_lock(compile_serializer, hunk);
  218.   hunk[VARIABLE_COMPILED_TYPE] = (OBJECT_NEW_TYPE (TC_UNINTERNED_SYMBOL, sym));
  219.   hunk[VARIABLE_OFFSET] = SHARP_F;
  220.   remove_lock(compile_serializer);
  221.  
  222.   return (MEMORY_LOC (sym, SYMBOL_GLOBAL_VALUE));
  223. }
  224.  
  225. /* Shallow lookup performed "out of line" by various procedures.
  226.    It takes care of invoking deep_lookup when necessary.
  227.  */
  228.  
  229. extern SCHEME_OBJECT *
  230.   EXFUN (lookup_cell, (SCHEME_OBJECT *, SCHEME_OBJECT));
  231.  
  232. SCHEME_OBJECT *
  233. DEFUN (lookup_cell, (hunk, env),
  234.        SCHEME_OBJECT * hunk
  235.        AND SCHEME_OBJECT env)
  236. {
  237.   SCHEME_OBJECT *cell, value;
  238.   long trap_kind;
  239.  
  240.   lookup(cell, env, hunk, repeat_lookup_cell);
  241.  
  242.   value = MEMORY_FETCH (cell[0]);
  243.  
  244.   if (OBJECT_TYPE (value) != TC_REFERENCE_TRAP)
  245.   {
  246.     return (cell);
  247.   }
  248.  
  249.   get_trap_kind(trap_kind, value);
  250.   switch(trap_kind)
  251.   {
  252.     case TRAP_DANGEROUS:
  253.     case TRAP_UNBOUND_DANGEROUS:
  254.     case TRAP_UNASSIGNED_DANGEROUS:
  255.     case TRAP_FLUID_DANGEROUS:
  256.     case TRAP_COMPILER_CACHED_DANGEROUS:
  257.       return (deep_lookup(env, hunk[VARIABLE_SYMBOL], hunk));
  258.  
  259.     case TRAP_COMPILER_CACHED:
  260.     case TRAP_FLUID:
  261.     case TRAP_UNBOUND:
  262.     case TRAP_UNASSIGNED:
  263.       return (cell);
  264.  
  265.     default:
  266.       return (illegal_trap_object);
  267.   }
  268. }
  269.  
  270. /* Full lookup end code.
  271.    deep_lookup_end handles all the complicated and dangerous cases.
  272.    cell is the value cell (supposedly found by deep_lookup).  Hunk is
  273.    the address of the scode variable object which may need to be
  274.    recompiled if the reference is dangerous.
  275.  */
  276.  
  277. long
  278. DEFUN (deep_lookup_end, (cell, hunk),
  279.        SCHEME_OBJECT * cell
  280.        AND SCHEME_OBJECT * hunk)
  281. {
  282.   long trap_kind, return_value;
  283.   Boolean repeat_p;
  284.  
  285.   do {
  286.     repeat_p = false;
  287.     Val = MEMORY_FETCH (cell[0]);
  288.     FUTURE_VARIABLE_SPLICE (((SCHEME_OBJECT) cell), 0, Val);
  289.     if (!(REFERENCE_TRAP_P(Val)))
  290.     {
  291.       return (PRIM_DONE);
  292.     }
  293.  
  294.     /* Remarks:
  295.        In the code below, break means uncompile the variable,
  296.        while continue means do not.
  297.        If repeat_p is set the whole process is redone, but since the
  298.        "danger bit" is kept on the outermost trap, the "uncompilation"
  299.        will not be affected by subsequent iterations.
  300.      */
  301.  
  302.     get_trap_kind(trap_kind, Val);
  303.     switch(trap_kind)
  304.     {
  305.       /* The following cases are divided into pairs:
  306.      the non-dangerous version leaves the compilation alone.
  307.      The dangerous version uncompiles.
  308.        */
  309.  
  310.       case TRAP_UNASSIGNED:
  311.     return (ERR_UNASSIGNED_VARIABLE);
  312.  
  313.       case TRAP_UNASSIGNED_DANGEROUS:
  314.     return_value = ERR_UNASSIGNED_VARIABLE;
  315.     break;
  316.  
  317.       case TRAP_DANGEROUS:
  318.       {
  319.     SCHEME_OBJECT trap_value;
  320.  
  321.     trap_value = Val;
  322.     Val = (MEMORY_REF (trap_value, TRAP_EXTRA));
  323.     FUTURE_VARIABLE_SPLICE (trap_value, TRAP_EXTRA, Val);
  324.     return_value = PRIM_DONE;
  325.     break;
  326.       }
  327.  
  328.       case TRAP_FLUID:
  329.       case TRAP_FLUID_DANGEROUS:
  330.     cell = lookup_fluid(Val);
  331.     repeat_p = true;
  332.     if (trap_kind == TRAP_FLUID)
  333.       continue;
  334.     break;
  335.  
  336.       case TRAP_COMPILER_CACHED:
  337.       case TRAP_COMPILER_CACHED_DANGEROUS:
  338.     cell = MEMORY_LOC (MEMORY_REF (Val, TRAP_EXTRA), TRAP_EXTENSION_CELL);
  339.     repeat_p = true;
  340.     if (trap_kind == TRAP_COMPILER_CACHED)
  341.       continue;
  342.     break;
  343.  
  344.       case TRAP_UNBOUND:
  345.     return (ERR_UNBOUND_VARIABLE);
  346.  
  347.       case TRAP_UNBOUND_DANGEROUS:
  348.     return_value = ERR_UNBOUND_VARIABLE;
  349.     break;
  350.  
  351.       default:
  352.     return_value = ERR_ILLEGAL_REFERENCE_TRAP;
  353.     break;
  354.     }
  355.  
  356.     /* The reference was dangerous, uncompile the variable. */
  357.     {
  358.       Lock_Handle compile_serializer;
  359.  
  360.       setup_lock(compile_serializer, hunk);
  361.       hunk[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
  362.       hunk[VARIABLE_OFFSET] = SHARP_F;
  363.       remove_lock(compile_serializer);
  364.     }
  365.  
  366.   } while (repeat_p);
  367.  
  368.   return (return_value);
  369. }
  370.  
  371. /* Simple lookup finalization.
  372.    All the hairy cases are left to deep_lookup_end.
  373.    env is the environment where the reference was supposedly resolved.
  374.    If there is any question about the validity of the resolution (due
  375.    to dangerousness, for example), a deep lookup operation is
  376.    performed, and control is given to deep_lookup_end.
  377.  */
  378.  
  379. long
  380. DEFUN (lookup_end, (cell, env, hunk),
  381.        SCHEME_OBJECT * cell
  382.        AND SCHEME_OBJECT env
  383.        AND SCHEME_OBJECT * hunk)
  384. {
  385.   long trap_kind;
  386.  
  387. lookup_end_restart:
  388.   Val = MEMORY_FETCH (cell[0]);
  389.   FUTURE_VARIABLE_SPLICE (((SCHEME_OBJECT) cell), 0, Val);
  390.  
  391.   if (!(REFERENCE_TRAP_P(Val)))
  392.   {
  393.     return (PRIM_DONE);
  394.   }
  395.  
  396.   get_trap_kind(trap_kind, Val);
  397.   switch(trap_kind)
  398.   {
  399.     case TRAP_DANGEROUS:
  400.     case TRAP_UNBOUND_DANGEROUS:
  401.     case TRAP_UNASSIGNED_DANGEROUS:
  402.     case TRAP_FLUID_DANGEROUS:
  403.     case TRAP_COMPILER_CACHED_DANGEROUS:
  404.       return
  405.     (deep_lookup_end(deep_lookup(env, hunk[VARIABLE_SYMBOL], hunk),
  406.              hunk));
  407.  
  408.     case TRAP_COMPILER_CACHED:
  409.       cell = MEMORY_LOC (MEMORY_REF (Val, TRAP_EXTRA), TRAP_EXTENSION_CELL);
  410.       goto lookup_end_restart;
  411.  
  412.     case TRAP_FLUID:
  413.       cell = lookup_fluid(Val);
  414.       goto lookup_end_restart;
  415.  
  416.     case TRAP_UNBOUND:
  417.       return (ERR_UNBOUND_VARIABLE);
  418.  
  419.     case TRAP_UNASSIGNED:
  420.       return (ERR_UNASSIGNED_VARIABLE);
  421.  
  422.     default:
  423.       return (ERR_ILLEGAL_REFERENCE_TRAP);
  424.   }
  425. }
  426.  
  427. /* Complete assignment finalization.
  428.  
  429.    deep_assignment_end handles all dangerous cases, and busts compiled
  430.    code operator reference caches as appropriate.  It is similar to
  431.    deep_lookup_end.
  432.    value is the new value for the variable.
  433.    force forces an assignment if the variable is unbound.  This is
  434.    used for redefinition in the global environment
  435.  
  436.    Notes on multiprocessor locking:
  437.  
  438.    The lock for assignment is usually in the original value cell in
  439.    the environment structure.
  440.    There are two cases where it is not:
  441.  
  442.    - Deep fluid variables.  The lock is in the fluid value cell
  443.    corresponding to this process.  The original lock is removed before
  444.    the fluid list is examined.
  445.  
  446.    - Compiler cached variables.  The lock is in the new value cell.
  447.    It is here so that compiled code can also lock it, since it does
  448.    not have a pointer to the environment structure at all.  The lock
  449.    is moved (updated) from the original location to the new location.
  450.    Ideally the original lock is not released until the new one is
  451.    acquired, but we may not be able to guarantee this.
  452.    The code is carefully written so that a weaker condition makes it
  453.    valid.  The condition is that locks should be granted in the order
  454.    of request.  The reason for this is that the code which can
  455.    affect an operation must acquire the same locks and in the same
  456.    order, thus if there is no interleaving of these operations, the
  457.    result will be correct.
  458.  
  459.    Important:
  460.  
  461.    A re-definition can take place before the lock is grabbed in this
  462.    code and we will be clobbering the wrong cell.  To be paranoid we
  463.    should redo the lookup while we have the cell locked and confirm
  464.    that this is still valid, but this is hard to do here.
  465.    Alternatively the lock could be grabbed by the caller and passed as
  466.    an argument after confirming the correctness of the binding.  A
  467.    third option (the one in place now) is not to worry about this,
  468.    saying that there is a race condition in the user code and that the
  469.    definition happened after this assignment.  For more precise
  470.    sequencing, the user should synchronize her/his assignments and
  471.    definitions her/himself.
  472.  
  473.    assignment_end suffers from this problem as well.
  474.  
  475.  */
  476.  
  477. #define RESULT(value)                            \
  478. {                                    \
  479.   return_value = (value);                        \
  480.   break;                                \
  481. }
  482.  
  483. #define UNCOMPILE(value)                        \
  484. {                                    \
  485.   uncompile_p = true;                            \
  486.   return_value = (value);                        \
  487.   break;                                \
  488. }
  489.  
  490. #define ABORT(value)                            \
  491. {                                    \
  492.   remove_lock(set_serializer);                        \
  493.   return (value);                            \
  494. }
  495.  
  496. #define REDO()                                \
  497. {                                    \
  498.   repeat_p = true;                            \
  499.   break;                                \
  500. }
  501.  
  502. long
  503. DEFUN (deep_assignment_end, (cell, hunk, value, force),
  504.        fast SCHEME_OBJECT * cell
  505.        AND SCHEME_OBJECT * hunk
  506.        AND SCHEME_OBJECT value
  507.        AND Boolean force)
  508. {
  509.   Lock_Handle set_serializer;
  510.   long trap_kind, return_value;
  511.   SCHEME_OBJECT bogus_unassigned, extension, saved_extension, saved_value;
  512.   Boolean repeat_p, uncompile_p, fluid_lock_p;
  513.  
  514.   /* State variables */
  515.   saved_extension = SHARP_F;
  516.   uncompile_p = false;
  517.   fluid_lock_p = false;
  518.  
  519.   bogus_unassigned = Get_Fixed_Obj_Slot(Non_Object);
  520.   if (value == bogus_unassigned)
  521.     value = UNASSIGNED_OBJECT;
  522.  
  523.   setup_lock(set_serializer, cell);
  524.  
  525.   do {
  526.  
  527.     repeat_p = false;
  528.     Val = *cell;
  529.  
  530.     if (!(REFERENCE_TRAP_P(Val)))
  531.     {
  532.       *cell = value;
  533.       RESULT(PRIM_DONE);
  534.     }
  535.  
  536.     /* Below, break means uncompile the variable. */
  537.  
  538.     get_trap_kind(trap_kind, Val);
  539.  
  540.     switch(trap_kind)
  541.     {
  542.       case TRAP_DANGEROUS:
  543.         Val = MEMORY_REF (Val, TRAP_EXTRA);
  544.     if (value == UNASSIGNED_OBJECT)
  545.     {
  546.       *cell = DANGEROUS_UNASSIGNED_OBJECT;
  547.     }
  548.     else
  549.     {
  550.       Do_Store_No_Lock ((MEMORY_LOC (*cell, TRAP_EXTRA)), value);
  551.     }
  552.     UNCOMPILE(PRIM_DONE);
  553.  
  554.       case TRAP_UNBOUND:
  555.     if (!force)
  556.     {
  557.       UNCOMPILE(ERR_UNBOUND_VARIABLE)
  558.     }
  559.     /* Fall through */
  560.  
  561.       case TRAP_UNASSIGNED:
  562.     Val = bogus_unassigned;
  563.     *cell = value;
  564.     RESULT(PRIM_DONE);
  565.  
  566.       case TRAP_UNBOUND_DANGEROUS:
  567.     if (!force)
  568.     {
  569.       UNCOMPILE(ERR_UNBOUND_VARIABLE);
  570.     }
  571.  
  572.     if (value == UNASSIGNED_OBJECT)
  573.     {
  574.       *cell = DANGEROUS_UNASSIGNED_OBJECT;
  575.       UNCOMPILE(PRIM_DONE);
  576.     }
  577.     /* Fall through */
  578.  
  579.       case TRAP_UNASSIGNED_DANGEROUS:
  580.     Val = bogus_unassigned;
  581.     if (value != UNASSIGNED_OBJECT)
  582.     {
  583.       SCHEME_OBJECT result;
  584.  
  585.       if (GC_allocate_test(2))
  586.       {
  587.         Request_GC(2);
  588.         ABORT(PRIM_INTERRUPT);
  589.       }
  590.       result = MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, Free);
  591.       *Free++ = DANGEROUS_OBJECT;
  592.       *Free++ = value;
  593.       *cell = result;
  594.     }
  595.     UNCOMPILE(PRIM_DONE);
  596.  
  597.       case TRAP_EXPENSIVE:
  598.     /* This should only happen if we have been invoked by
  599.        compiler_assignment_end invoked by compiler_reference_trap;
  600.      */
  601.     extension = cell[TRAP_EXTENSION_CLONE];
  602.     goto compiler_cache_assignment;
  603.  
  604.       case TRAP_COMPILER_CACHED_DANGEROUS:
  605.     uncompile_p = true;
  606.     /* Fall through */
  607.  
  608.       case TRAP_COMPILER_CACHED:
  609.     extension = FAST_MEMORY_REF (Val, TRAP_EXTRA);
  610.  
  611. compiler_cache_assignment:
  612.     {
  613.       SCHEME_OBJECT references;
  614.  
  615.       /* Unlock and lock at the new value cell. */
  616.  
  617.       references = (FAST_MEMORY_REF (extension,
  618.                      TRAP_EXTENSION_REFERENCES));
  619.       cell = (MEMORY_LOC (extension, TRAP_EXTENSION_CELL));
  620.       update_lock (set_serializer, cell);
  621.  
  622.       if ((FAST_MEMORY_REF (references, TRAP_REFERENCES_OPERATOR))
  623.           != SHARP_F)
  624.       {
  625.         if (saved_extension != SHARP_F)
  626.         {
  627.           ABORT(ERR_BROKEN_VARIABLE_CACHE);
  628.         }
  629.         saved_extension = extension;
  630.         saved_value = *cell;
  631.       }
  632.       REDO();
  633.     }
  634.  
  635.       /* Remarks:
  636.      If this is the inner trap of a compiler cache, and there are
  637.      uuo links, there will actually be no recaching, since the old
  638.      contents and the new one will be the fluid trap, and the
  639.      links will already be set up for the fluid trap.  Thus we can
  640.      temporarily unlock while the iteration takes place.
  641.        */
  642.       case TRAP_FLUID_DANGEROUS:
  643.     uncompile_p = true;
  644.     /* Fall through */
  645.  
  646.       case TRAP_FLUID:
  647.     fluid_lock_p = true;
  648.     remove_lock(set_serializer);
  649.     cell = lookup_fluid(Val);
  650.     setup_lock(set_serializer, cell);
  651.     REDO();
  652.  
  653.       default:
  654.     UNCOMPILE(ERR_ILLEGAL_REFERENCE_TRAP);
  655.     }
  656.   } while (repeat_p);
  657.  
  658.   if (saved_extension != SHARP_F)
  659.   {
  660.     long recache_uuo_links ();
  661.  
  662.     if (fluid_lock_p)
  663.     {
  664.       /* Guarantee that there is a lock on the variable cache around
  665.      the call to recache_uuo_links.
  666.        */
  667.  
  668.       update_lock (set_serializer,
  669.            (MEMORY_LOC (saved_extension, TRAP_EXTENSION_CELL)));
  670.     }
  671.  
  672.     /* NOTE:
  673.        recache_uuo_links can take an arbitrary amount of time since
  674.        there may be an internal lock and the code may have to uncache
  675.        arbitrarily many links.
  676.        Deadlock should not occur since both locks are always acquired
  677.        in the same order.
  678.      */
  679.  
  680.     return_value = (recache_uuo_links (saved_extension, saved_value));
  681.     remove_lock (set_serializer);
  682.  
  683.     if (return_value != PRIM_DONE)
  684.     {
  685.       return (return_value);
  686.     }
  687.   }
  688.   else
  689.   {
  690.     remove_lock (set_serializer);
  691.   }
  692.  
  693.   /* This must be done after the assignment lock has been removed,
  694.      to avoid potential deadlock.
  695.    */
  696.  
  697.   if (uncompile_p)
  698.   {
  699.     /* The reference was dangerous, uncompile the variable. */
  700.  
  701.     Lock_Handle compile_serializer;
  702.  
  703.     setup_lock (compile_serializer, hunk);
  704.     hunk[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
  705.     hunk[VARIABLE_OFFSET] = SHARP_F;
  706.     remove_lock (compile_serializer);
  707.   }
  708.  
  709.   return (return_value);
  710. }
  711.  
  712. #undef ABORT
  713. #undef REDO
  714. #undef RESULT
  715. #undef UNCOMPILE
  716.  
  717. /* Simple assignment end.
  718.    assignment_end lets deep_assignment_end handle all the hairy cases.
  719.    It is similar to lookup_end, but there is some hair for
  720.    unassignedness and compiled code cached references.
  721.  */
  722.  
  723. long
  724. DEFUN (assignment_end, (cell, env, hunk, value),
  725.        fast SCHEME_OBJECT * cell
  726.        AND SCHEME_OBJECT env
  727.        AND SCHEME_OBJECT * hunk
  728.        AND SCHEME_OBJECT value)
  729. {
  730.   Lock_Handle set_serializer;
  731.   SCHEME_OBJECT bogus_unassigned;
  732.   long temp;
  733.  
  734.   bogus_unassigned = Get_Fixed_Obj_Slot(Non_Object);
  735.   if (value == bogus_unassigned)
  736.     value = UNASSIGNED_OBJECT;
  737.  
  738. assignment_end_before_lock:
  739.  
  740.   setup_lock(set_serializer, cell);
  741.  
  742. assignment_end_after_lock:
  743.  
  744.   Val = *cell;
  745.  
  746.   if (!(REFERENCE_TRAP_P(Val)))
  747.   {
  748.     *cell = value;
  749.     remove_lock(set_serializer);
  750.     return (PRIM_DONE);
  751.   }
  752.  
  753.   get_trap_kind(temp, Val);
  754.   switch(temp)
  755.   {
  756.     case TRAP_DANGEROUS:
  757.     case TRAP_UNBOUND_DANGEROUS:
  758.     case TRAP_UNASSIGNED_DANGEROUS:
  759.     case TRAP_FLUID_DANGEROUS:
  760.     case TRAP_COMPILER_CACHED_DANGEROUS:
  761.       remove_lock(set_serializer);
  762.       return
  763.     (deep_assignment_end(deep_lookup(env, hunk[VARIABLE_SYMBOL], hunk),
  764.                  hunk,
  765.                  value,
  766.                  false));
  767.  
  768.     case TRAP_COMPILER_CACHED:
  769.     {
  770.       SCHEME_OBJECT extension, references;
  771.  
  772.       extension = FAST_MEMORY_REF (Val, TRAP_EXTRA);
  773.       references = FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES);
  774.  
  775.       if (FAST_MEMORY_REF (references, TRAP_REFERENCES_OPERATOR) != SHARP_F)
  776.       {
  777.     /* There are uuo links.
  778.        wimp out and let deep_assignment_end handle it.
  779.      */
  780.  
  781.     remove_lock(set_serializer);
  782.     return (deep_assignment_end(cell, hunk, value, false));
  783.       }
  784.       cell = MEMORY_LOC (extension, TRAP_EXTENSION_CELL);
  785.       update_lock(set_serializer, cell);
  786.       goto assignment_end_after_lock;
  787.     }
  788.  
  789.     case TRAP_FLUID:
  790.       remove_lock(set_serializer);
  791.       cell = lookup_fluid(Val);
  792.       goto assignment_end_before_lock;
  793.  
  794.     case TRAP_UNBOUND:
  795.       temp = ERR_UNBOUND_VARIABLE;
  796.       break;
  797.  
  798.     case TRAP_UNASSIGNED:
  799.       Val = bogus_unassigned;
  800.       *cell = value;
  801.       temp = PRIM_DONE;
  802.       break;
  803.  
  804.     default:
  805.       temp = ERR_ILLEGAL_REFERENCE_TRAP;
  806.       break;
  807.   }
  808.   remove_lock(set_serializer);
  809.   return (temp);
  810. }
  811.  
  812. /* Finds the fluid value cell associated with the reference trap on
  813.    this processor's fluid "binding" list.  It is just like ASSQ.
  814.  */
  815.  
  816. SCHEME_OBJECT *
  817. DEFUN (lookup_fluid, (trap), fast SCHEME_OBJECT trap)
  818. {
  819.   fast SCHEME_OBJECT fluids, *this_pair;
  820.  
  821.   fluids = Fluid_Bindings;
  822.  
  823.   if (Fluids_Debug)
  824.   {
  825.     Print_Expression(fluids, "Searching fluid bindings");
  826.   }
  827.  
  828.   while (PAIR_P(fluids))
  829.   {
  830.     this_pair = OBJECT_ADDRESS (FAST_PAIR_CAR (fluids));
  831.  
  832.     if (this_pair[CONS_CAR] == trap)
  833.     {
  834.       if (Fluids_Debug)
  835.       {
  836.     fprintf(stderr, "Fluid found.\n");
  837.       }
  838.  
  839.       return (&this_pair[CONS_CDR]);
  840.     }
  841.  
  842.     fluids = FAST_PAIR_CDR (fluids);
  843.   }
  844.  
  845.   /* Not found in fluid binding alist, so use default. */
  846.  
  847.   if (Fluids_Debug)
  848.   {
  849.     fprintf(stderr, "Fluid not found, using default.\n");
  850.   }
  851.  
  852.   return (MEMORY_LOC (trap, TRAP_EXTRA));
  853. }
  854.  
  855. /* Utilities for definition.
  856.  
  857.    redefinition is used when the definition is in fact an assignment.
  858.    A binding already exists in this frame.
  859.  
  860.    dangerize is invoked to guarantee that any variables "compiled" to
  861.    this location are recompiled at the next reference.
  862.  */
  863.  
  864. #define redefinition(cell, value) \
  865.   (deep_assignment_end (cell, fake_variable_object, value, true))
  866.  
  867. long
  868. DEFUN (definition, (cell, value, shadowed_p),
  869.        SCHEME_OBJECT * cell
  870.        AND SCHEME_OBJECT value
  871.        AND Boolean shadowed_p)
  872. {
  873.   if (shadowed_p)
  874.     return (redefinition (cell, value));
  875.   else
  876.   {
  877.     Lock_Handle set_serializer;
  878.  
  879.     setup_lock (set_serializer, cell);
  880.     if (*cell == DANGEROUS_UNBOUND_OBJECT)
  881.     {
  882.       *cell = value;
  883.       remove_lock (set_serializer);
  884.       return (PRIM_DONE);
  885.     }
  886.     else
  887.     {
  888.       /* Unfortunate fact of life: This binding will be dangerous
  889.      even if there was no need, but this is the only way to
  890.      guarantee consistent values.
  891.        */
  892.       remove_lock (set_serializer);
  893.       return (redefinition (cell, value));
  894.     }
  895.   }
  896. }
  897.  
  898. long
  899. DEFUN (dangerize, (cell, sym),
  900.        fast SCHEME_OBJECT * cell
  901.        AND SCHEME_OBJECT sym)
  902. {
  903.   Lock_Handle set_serializer;
  904.   fast long temp;
  905.   SCHEME_OBJECT trap;
  906.  
  907.   setup_lock (set_serializer, cell);
  908.   if (!(REFERENCE_TRAP_P (*cell)))
  909.   {
  910.     if (GC_allocate_test (2))
  911.     {
  912.       remove_lock (set_serializer);
  913.       Request_GC (2);
  914.       return (PRIM_INTERRUPT);
  915.     }
  916.     trap = (MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, Free));
  917.     *Free++ = DANGEROUS_OBJECT;
  918.     *Free++ = *cell;
  919.     *cell = trap;
  920.     remove_lock (set_serializer);
  921.     return (simple_uncache (cell, sym));
  922.   }
  923.  
  924.   get_trap_kind (temp, *cell);
  925.   switch (temp)
  926.   {
  927.     case TRAP_UNBOUND_DANGEROUS:
  928.     case TRAP_UNASSIGNED_DANGEROUS:
  929.     case TRAP_DANGEROUS:
  930.     case TRAP_FLUID_DANGEROUS:
  931.       break;
  932.  
  933.     case TRAP_COMPILER_CACHED:
  934.       Do_Store_No_Lock
  935.     ((MEMORY_LOC (*cell, TRAP_TAG)),
  936.      (LONG_TO_UNSIGNED_FIXNUM (TRAP_COMPILER_CACHED_DANGEROUS)));
  937.       /* Fall through */
  938.  
  939.     case TRAP_COMPILER_CACHED_DANGEROUS:
  940.     {
  941.       remove_lock (set_serializer);
  942.       return (compiler_uncache (cell, sym));
  943.     }
  944.  
  945.     case TRAP_FLUID:
  946.       Do_Store_No_Lock
  947.     ((MEMORY_LOC (*cell, TRAP_TAG)),
  948.      (LONG_TO_UNSIGNED_FIXNUM (TRAP_FLUID_DANGEROUS)));
  949.       break;
  950.  
  951.     case TRAP_UNBOUND:
  952.       *cell = DANGEROUS_UNBOUND_OBJECT;
  953.       break;
  954.  
  955.     case TRAP_UNASSIGNED:
  956.       *cell = DANGEROUS_UNASSIGNED_OBJECT;
  957.       break;
  958.  
  959.     default:
  960.       remove_lock (set_serializer);
  961.       return (ERR_ILLEGAL_REFERENCE_TRAP);
  962.   }
  963.   remove_lock (set_serializer);
  964.   return (simple_uncache (cell, sym));
  965. }
  966.  
  967. /* The core of the incremental definition mechanism.
  968.  
  969.    It takes care of dangerizing any bindings being shadowed by this
  970.    definition, extending the frames appropriately, and uncaching or
  971.    recaching (according to the DEFINITION_RECACHES_EAGERLY flag) any
  972.    compiled code reference caches which might be affected by the new
  973.    definition.
  974.  
  975.    *UNDEFINE*: If (local?) undefine is ever implemented, it suffices
  976.    to set the value cell to DANGEROUS_UNBOUND_OBJECT, uncache all the
  977.    compiler cached variables to the location, and rewrite the code
  978.    below slightly as implied by the comments tagged *UNDEFINE*.
  979.  */
  980.  
  981. long
  982. DEFUN (extend_frame,
  983.        (env, sym, value, original_frame, recache_p),
  984.        SCHEME_OBJECT env
  985.        AND SCHEME_OBJECT sym
  986.        AND SCHEME_OBJECT value
  987.        AND SCHEME_OBJECT original_frame
  988.        AND Boolean recache_p)
  989. {
  990.   Lock_Handle extension_serializer;
  991.   SCHEME_OBJECT extension, the_procedure;
  992.   fast SCHEME_OBJECT *scan;
  993.   long aux_count;
  994.  
  995.   if ((OBJECT_TYPE (env)) == GLOBAL_ENV)
  996.   {
  997.     /* *UNDEFINE*: If undefine is ever implemented, this code need not
  998.        change: There are no shadowed bindings that need to be
  999.        recached.
  1000.      */
  1001.     if ((OBJECT_DATUM (env)) != GO_TO_GLOBAL)
  1002.     {
  1003.       if (env == original_frame)
  1004.       {
  1005.     return (ERR_BAD_FRAME);
  1006.       }
  1007.       else
  1008.       {
  1009.     /* We have a new definition in a chain rooted at the empty
  1010.        environment.
  1011.        We need not uncache/recache, but we need to set all
  1012.        global state accordingly.
  1013.        We use a cell which never needs uncacheing/recacheing
  1014.        and use the ordinary code otherwise.
  1015.  
  1016.        This is done only because of compiler cached variables.
  1017.      */
  1018.     return (compiler_uncache ((unbound_trap_object), sym));
  1019.       }
  1020.     }
  1021.     else if (env == original_frame)
  1022.     {
  1023.       return (redefinition ((MEMORY_LOC (sym, SYMBOL_GLOBAL_VALUE)),
  1024.                 value));
  1025.     }
  1026.     else
  1027.     {
  1028.       return (dangerize ((MEMORY_LOC (sym, SYMBOL_GLOBAL_VALUE)), sym));
  1029.     }
  1030.   }
  1031.  
  1032.   the_procedure = (MEMORY_REF (env, ENVIRONMENT_FUNCTION));
  1033.   if ((OBJECT_TYPE (the_procedure)) == AUX_LIST_TYPE)
  1034.     the_procedure = (MEMORY_REF (the_procedure, ENV_EXTENSION_PROCEDURE));
  1035.  
  1036.   /* Search the formals. */
  1037.  
  1038.   {
  1039.     fast long count;
  1040.     SCHEME_OBJECT formals;
  1041.  
  1042.     formals = (FAST_MEMORY_REF ((FAST_MEMORY_REF (the_procedure,
  1043.                           PROCEDURE_LAMBDA_EXPR)),
  1044.                 LAMBDA_FORMALS));
  1045.     for (count = ((VECTOR_LENGTH (formals)) - 1),
  1046.      scan = (MEMORY_LOC (formals, VECTOR_DATA + 1));
  1047.      count > 0;
  1048.      count -= 1)
  1049.     {
  1050.       /* *UNDEFINE*: If undefine is ever implemented, this code must
  1051.      check whether the value is DANGEROUS_UNBOUND_OBJECT, and if
  1052.      so, a search must be done to cause the shadowed compiler
  1053.      cached variables to be recached, as in the aux case below.
  1054.        */
  1055.       if (*scan++ == sym)
  1056.       {
  1057.     long offset;
  1058.  
  1059.     offset = (1 + (VECTOR_LENGTH (formals))) - count;
  1060.     if (env == original_frame)
  1061.     {
  1062.       return (redefinition ((MEMORY_LOC (env, offset)), value));
  1063.     }
  1064.     else
  1065.     {
  1066.       return (dangerize ((MEMORY_LOC (env, offset)), sym));
  1067.     }
  1068.       }
  1069.     }
  1070.   }
  1071.  
  1072.   /* Guarantee that there is an extension slot. */
  1073.  
  1074. redo_aux_lookup:
  1075.  
  1076.   setup_lock (extension_serializer, (OBJECT_ADDRESS (env)));
  1077.   extension = (FAST_MEMORY_REF (env, ENVIRONMENT_FUNCTION));
  1078.   if ((OBJECT_TYPE (extension)) != AUX_LIST_TYPE)
  1079.   {
  1080.     fast long i;
  1081.  
  1082.     if (GC_allocate_test (AUX_LIST_INITIAL_SIZE))
  1083.     {
  1084.       remove_lock (extension_serializer);
  1085.       Request_GC (AUX_LIST_INITIAL_SIZE);
  1086.       return (PRIM_INTERRUPT);
  1087.     }
  1088.     scan = Free;
  1089.     extension = (MAKE_POINTER_OBJECT (AUX_LIST_TYPE, scan));
  1090.  
  1091.     scan[ENV_EXTENSION_HEADER] =
  1092.       (MAKE_OBJECT (TC_MANIFEST_VECTOR, (AUX_LIST_INITIAL_SIZE - 1)));
  1093.  
  1094.     scan[ENV_EXTENSION_PARENT_FRAME] =
  1095.       (MEMORY_REF (the_procedure, PROCEDURE_ENVIRONMENT));
  1096.  
  1097.     scan[ENV_EXTENSION_PROCEDURE] = the_procedure;
  1098.  
  1099.     scan[ENV_EXTENSION_COUNT] = (Make_Local_Offset (0));
  1100.  
  1101.     for (i = AUX_CHUNK_SIZE, scan += AUX_LIST_FIRST;
  1102.      --i >= 0;)
  1103.       *scan++ = SHARP_F;
  1104.  
  1105.     Free = scan;
  1106.     Do_Store_No_Lock ((MEMORY_LOC (env, ENVIRONMENT_FUNCTION)), extension);
  1107.   }
  1108.   aux_count = (Lexical_Offset (FAST_MEMORY_REF (extension, AUX_LIST_COUNT)));
  1109.   remove_lock (extension_serializer);
  1110.  
  1111.   /* Search the aux list. */
  1112.  
  1113.   {
  1114.     fast long count;
  1115.  
  1116.     scan = (OBJECT_ADDRESS (extension));
  1117.     count = aux_count;
  1118.     scan += AUX_LIST_FIRST;
  1119.  
  1120.     while (--count >= 0)
  1121.     {
  1122.       if ((FAST_PAIR_CAR (*scan)) == sym)
  1123.       {
  1124.     scan = (PAIR_CDR_LOC (*scan));
  1125.  
  1126.     /* This is done only because of compiler cached variables.
  1127.        In their absence, this conditional is unnecessary.
  1128.  
  1129.        *UNDEFINE*: This would also have to be done for other kinds
  1130.        of bindings if undefine is ever implemented.  See the
  1131.        comments above.
  1132.      */
  1133.     if ((MEMORY_FETCH (scan[0])) == DANGEROUS_UNBOUND_OBJECT)
  1134.     {
  1135.       long temp;
  1136.  
  1137.       temp =
  1138.         (compiler_uncache
  1139.          (deep_lookup ((FAST_MEMORY_REF (extension,
  1140.                          ENV_EXTENSION_PARENT_FRAME)),
  1141.                sym,
  1142.                fake_variable_object),
  1143.           sym));
  1144.  
  1145.       if ((temp != PRIM_DONE) || (env != original_frame))
  1146.       {
  1147.         return (temp);
  1148.       }
  1149.       return (shadowing_recache (scan, env, sym, value, true));
  1150.     }
  1151.  
  1152.     if (env == original_frame)
  1153.     {
  1154.       return (redefinition (scan, value));
  1155.     }
  1156.     else
  1157.     {
  1158.       return (dangerize (scan, sym));
  1159.     }
  1160.       }
  1161.       scan += 1;
  1162.     }
  1163.   }
  1164.  
  1165.   /* Not found in this frame at all. */
  1166.  
  1167.   {
  1168.     fast long temp;
  1169.  
  1170.     temp =
  1171.       (extend_frame ((FAST_MEMORY_REF (extension, ENV_EXTENSION_PARENT_FRAME)),
  1172.              sym, SHARP_F, original_frame, recache_p));
  1173.  
  1174.     if (temp != PRIM_DONE)
  1175.     {
  1176.       return (temp);
  1177.     }
  1178.  
  1179.     /* Proceed to extend the frame:
  1180.        - If the frame is the one where the definition is occurring,
  1181.      put the value in the new value cell.
  1182.        - Otherwise, put a dangerous unbound trap there.
  1183.        - This code is careful to restart if some other process defines
  1184.          something in the meantime in this frame.
  1185.      */
  1186.  
  1187.     setup_lock (extension_serializer, (OBJECT_ADDRESS (env)));
  1188.     temp = (Lexical_Offset (FAST_MEMORY_REF (extension, AUX_LIST_COUNT)));
  1189.  
  1190.     if ((extension != (FAST_MEMORY_REF (env, ENVIRONMENT_FUNCTION))) ||
  1191.     (temp != aux_count))
  1192.     {
  1193.       remove_lock (extension_serializer);
  1194.       goto redo_aux_lookup;
  1195.     }
  1196.  
  1197.     scan = (OBJECT_ADDRESS (extension));
  1198.  
  1199.     if ((temp + (AUX_LIST_FIRST - 1)) == (VECTOR_LENGTH (extension)))
  1200.     {
  1201.       fast long i;
  1202.       fast SCHEME_OBJECT *fast_free;
  1203.  
  1204.       i = ((2 * temp) + AUX_LIST_FIRST);
  1205.  
  1206.       if (GC_allocate_test (i))
  1207.       {
  1208.     remove_lock (extension_serializer);
  1209.     Request_GC (i);
  1210.     return (PRIM_INTERRUPT);
  1211.       }
  1212.  
  1213.       fast_free = Free;
  1214.       i -= 1;
  1215.  
  1216.       scan += 1;
  1217.       *fast_free++ = (MAKE_OBJECT (TC_MANIFEST_VECTOR, i));
  1218.       for (i = (temp + (AUX_LIST_FIRST - 1)); --i >= 0; )
  1219.     *fast_free++ = *scan++;
  1220.       for (i = temp; --i >= 0; )
  1221.     *fast_free++ = SHARP_F;
  1222.  
  1223.       scan = Free;
  1224.       Free = fast_free;
  1225.       Do_Store_No_Lock
  1226.     ((MEMORY_LOC (env, ENVIRONMENT_FUNCTION)),
  1227.      (MAKE_POINTER_OBJECT (AUX_LIST_TYPE, scan)));
  1228.     }
  1229.  
  1230.     if (GC_allocate_test (2))
  1231.     {
  1232.       remove_lock (extension_serializer);
  1233.       Request_GC (2);
  1234.       return (PRIM_INTERRUPT);
  1235.     }
  1236.  
  1237.     {
  1238.       SCHEME_OBJECT result;
  1239.  
  1240.       result = (MAKE_POINTER_OBJECT (TC_LIST, Free));
  1241.       *Free++ = sym;
  1242.       *Free++ = DANGEROUS_UNBOUND_OBJECT;
  1243.  
  1244.       scan[temp + AUX_LIST_FIRST] = result;
  1245.       scan[AUX_LIST_COUNT] = (Make_Local_Offset (temp + 1));
  1246.  
  1247.       remove_lock (extension_serializer);
  1248.  
  1249.       if ((env != original_frame) || (!recache_p))
  1250.     return (PRIM_DONE);
  1251.       else
  1252.     return (shadowing_recache ((Free - 1), env, sym, value, false));
  1253.     }
  1254.   }
  1255. }
  1256.  
  1257. /* Top level of lookup code.
  1258.    These are the procedures invoked from outside this file.
  1259.  */
  1260.  
  1261. long
  1262. DEFUN (Lex_Ref, (env, var),
  1263.        SCHEME_OBJECT env
  1264.        AND SCHEME_OBJECT var)
  1265. {
  1266.   fast SCHEME_OBJECT *cell;
  1267.   SCHEME_OBJECT *hunk;
  1268.  
  1269.   hunk = OBJECT_ADDRESS (var);
  1270.   lookup(cell, env, hunk, repeat_lex_ref_lookup);
  1271.   return (lookup_end(cell, env, hunk));
  1272. }
  1273.  
  1274. long
  1275. DEFUN (Symbol_Lex_Ref, (env, sym),
  1276.        SCHEME_OBJECT env
  1277.        AND SCHEME_OBJECT sym)
  1278. {
  1279.   return (deep_lookup_end(deep_lookup(env, sym, fake_variable_object),
  1280.               fake_variable_object));
  1281. }
  1282.  
  1283. long
  1284. DEFUN (Lex_Set, (env, var, value),
  1285.        SCHEME_OBJECT env
  1286.        AND SCHEME_OBJECT var
  1287.        AND SCHEME_OBJECT value)
  1288. {
  1289.   fast SCHEME_OBJECT *cell;
  1290.   SCHEME_OBJECT *hunk;
  1291.  
  1292.   hunk = OBJECT_ADDRESS (var);
  1293.   lookup(cell, env, hunk, repeat_lex_set_lookup);
  1294.   return (assignment_end(cell, env, hunk, value));
  1295. }
  1296.  
  1297. long
  1298. DEFUN (Symbol_Lex_Set, (env, sym, value),
  1299.        SCHEME_OBJECT env
  1300.        AND SCHEME_OBJECT sym
  1301.        AND SCHEME_OBJECT value)
  1302. {
  1303.   return (deep_assignment_end(deep_lookup(env, sym, fake_variable_object),
  1304.                   fake_variable_object,
  1305.                   value,
  1306.                   false));
  1307. }
  1308.  
  1309. long
  1310. DEFUN (Local_Set, (env, sym, value),
  1311.        SCHEME_OBJECT env
  1312.        AND SCHEME_OBJECT sym
  1313.        AND SCHEME_OBJECT value)
  1314. {
  1315.   long result;
  1316.  
  1317.   if (Define_Debug)
  1318.   {
  1319.     fprintf(stderr,
  1320.         "\n;; Local_Set: defining %s.",
  1321.         (STRING_LOC ((MEMORY_REF (sym, SYMBOL_NAME)), 0)));
  1322.   }
  1323.   result = (extend_frame (env, sym, value, env, true));
  1324.   Val = sym;
  1325.   return (result);
  1326. }
  1327.  
  1328. long
  1329. DEFUN (safe_reference_transform, (reference_result), long reference_result)
  1330. {
  1331.   if (reference_result == ERR_UNASSIGNED_VARIABLE)
  1332.   {
  1333.     Val = UNASSIGNED_OBJECT;
  1334.     return (PRIM_DONE);
  1335.   }
  1336.   else
  1337.   {
  1338.     return (reference_result);
  1339.   }
  1340. }
  1341.  
  1342. long
  1343. DEFUN (safe_lex_ref, (env, var),
  1344.        SCHEME_OBJECT env
  1345.        AND SCHEME_OBJECT var)
  1346. {
  1347.   return (safe_reference_transform (Lex_Ref (env, var)));
  1348. }
  1349.  
  1350. long
  1351. DEFUN (safe_symbol_lex_ref, (env, sym),
  1352.        SCHEME_OBJECT env
  1353.        AND SCHEME_OBJECT sym)
  1354. {
  1355.   return (safe_reference_transform (Symbol_Lex_Ref (env, sym)));
  1356. }
  1357.  
  1358. long
  1359. DEFUN (unassigned_p_transform, (reference_result), long reference_result)
  1360. {
  1361.   switch (reference_result)
  1362.   {
  1363.     case ERR_UNASSIGNED_VARIABLE:
  1364.       Val = SHARP_T;
  1365.       return (PRIM_DONE);
  1366.  
  1367.     case PRIM_DONE:
  1368.       Val = SHARP_F;
  1369.       return (PRIM_DONE);
  1370.  
  1371.     case ERR_UNBOUND_VARIABLE:
  1372.     default:
  1373.       return (reference_result);
  1374.   }
  1375. }
  1376.  
  1377. extern long
  1378.   EXFUN (Symbol_Lex_unassigned_p, (SCHEME_OBJECT, SCHEME_OBJECT)),
  1379.   EXFUN (Symbol_Lex_unbound_p, (SCHEME_OBJECT, SCHEME_OBJECT));
  1380.  
  1381. long
  1382. DEFUN (Symbol_Lex_unassigned_p, (frame, symbol),
  1383.        SCHEME_OBJECT frame
  1384.        AND SCHEME_OBJECT symbol)
  1385. {
  1386.   return (unassigned_p_transform (Symbol_Lex_Ref (frame, symbol)));
  1387. }
  1388.  
  1389. long
  1390. DEFUN (Symbol_Lex_unbound_p, (frame, symbol),
  1391.        SCHEME_OBJECT frame
  1392.        AND SCHEME_OBJECT symbol)
  1393. {
  1394.   long result;
  1395.  
  1396.   result = (Symbol_Lex_Ref (frame, symbol));
  1397.   switch (result)
  1398.   {
  1399.     case ERR_UNASSIGNED_VARIABLE:
  1400.     case PRIM_DONE:
  1401.     {
  1402.       Val = SHARP_F;
  1403.       return (PRIM_DONE);
  1404.     }
  1405.  
  1406.     case ERR_UNBOUND_VARIABLE:
  1407.     {
  1408.       Val = SHARP_T;
  1409.       return (PRIM_DONE);
  1410.     }
  1411.  
  1412.     default:
  1413.       return (result);
  1414.   }
  1415. }
  1416.  
  1417. /* force_definition is used when access to the global environment is
  1418.    not allowed.  It finds the last frame where a definition can occur,
  1419.    and performs the definition in this frame.  It then returns the
  1420.    cell where the value is stored.  It's expensive and will hardly be
  1421.    used, but is provided for completeness.
  1422. */
  1423.  
  1424. SCHEME_OBJECT *
  1425. DEFUN (force_definition, (env, symbol, message),
  1426.        fast SCHEME_OBJECT env
  1427.        AND SCHEME_OBJECT symbol
  1428.        AND long * message)
  1429. {
  1430.   fast SCHEME_OBJECT previous;
  1431.  
  1432.   if (OBJECT_TYPE (env) == GLOBAL_ENV)
  1433.   {
  1434.     *message = ERR_BAD_FRAME;
  1435.     return ((SCHEME_OBJECT *) NULL);
  1436.   }
  1437.  
  1438.   do
  1439.   {
  1440.     previous = env;
  1441.     env = FAST_MEMORY_REF (MEMORY_REF (env, ENVIRONMENT_FUNCTION),
  1442.                PROCEDURE_ENVIRONMENT);
  1443.   } while (OBJECT_TYPE (env) != GLOBAL_ENV);
  1444.  
  1445.   *message = (Local_Set (previous, symbol, UNASSIGNED_OBJECT));
  1446.   if (*message != PRIM_DONE)
  1447.   {
  1448.     return ((SCHEME_OBJECT *) NULL);
  1449.   }
  1450.   return (deep_lookup(previous, symbol, fake_variable_object));
  1451. }
  1452.  
  1453. /* Macros to allow multiprocessor interlocking in
  1454.    compiler caching and recaching.
  1455.  
  1456.    The defaults are NOPs, but can be overriden by machine dependent
  1457.    include files or config.h
  1458.  */
  1459.  
  1460. #ifndef update_uuo_prolog
  1461. #define update_uuo_prolog()
  1462. #endif
  1463.  
  1464. #ifndef update_uuo_epilog
  1465. #define update_uuo_epilog()
  1466. #endif
  1467.  
  1468. #ifndef compiler_cache_prolog
  1469. #define compiler_cache_prolog()
  1470. #endif
  1471.  
  1472. #ifndef compiler_cache_epilog
  1473. #define compiler_cache_epilog()
  1474. #endif
  1475.  
  1476. #ifndef compiler_trap_prolog
  1477. #define compiler_trap_prolog()
  1478. #endif
  1479.  
  1480. #ifndef compiler_trap_epilog
  1481. #define compiler_trap_epilog()
  1482. #endif
  1483.  
  1484. #ifndef compiler_uncache_prolog
  1485. #define compiler_uncache_prolog()
  1486. #endif
  1487.  
  1488. #ifndef compiler_uncache_epilog
  1489. #define compiler_uncache_epilog()
  1490. #endif
  1491.  
  1492. #ifndef compiler_recache_prolog
  1493. #define compiler_recache_prolog()
  1494. #endif
  1495.  
  1496. #ifndef compiler_recache_epilog
  1497. #define compiler_recache_epilog()
  1498. #endif
  1499.  
  1500. /* Fast variable reference mechanism for compiled code.
  1501.  
  1502.    compiler_cache is the core of the variable caching mechanism.
  1503.  
  1504.    It creates a variable cache for the variable at the specified cell,
  1505.    if needed, and stores it or a related object in the location
  1506.    specified by (block, offset).  It adds this reference to the
  1507.    appropriate reference list for further updating.
  1508.  
  1509.    If the reference is a lookup reference, the cache itself is stored.
  1510.  
  1511.    If the reference is an assignment reference, there are two possibilities:
  1512.    - There are no operator references cached to this location.  The
  1513.    cache itself is stored.
  1514.    - There are operator references.  A fake cache (clone) is stored instead.
  1515.    This cache will make all assignments trap so that the cached
  1516.    operators can be updated.
  1517.  
  1518.    If the reference is an operator reference, a compiled procedure or a
  1519.    "fake" compiled procedure is stored.  Furthermore, if there were
  1520.    assignment references cached, and no fake cache had been installed,
  1521.    a fake cache is created and all the assignment references are
  1522.    updated to point to it.
  1523.  */
  1524.  
  1525. #ifndef PARALLEL_PROCESSOR
  1526.  
  1527. #define compiler_cache_consistency_check()
  1528.  
  1529. #else /* PARALLEL_PROCESSOR */
  1530.  
  1531. /* The purpose of this code is to avoid a lock gap.
  1532.    A re-definition can take place before the lock is grabbed
  1533.    and we will be caching to the wrong cell.
  1534.    To be paranoid we redo the lookup while we have the
  1535.    cell locked and confim that we still have the correct cell.
  1536.  
  1537.    Note that this lookup can be "shallow" since the result of
  1538.    the previous lookup is saved in my_variable.  The "shallow"
  1539.    lookup code takes care of performing a deep lookup if the
  1540.    cell has been "dangerized".
  1541.  */
  1542.  
  1543. #define compiler_cache_consistency_check()                \
  1544. {                                    \
  1545.   SCHEME_OBJECT *new_cell;                        \
  1546.                                     \
  1547.   compiler_cache_variable[VARIABLE_SYMBOL] = name;            \
  1548.   new_cell = (lookup_cell (compiler_cache_variable, env));        \
  1549.   if (cell != new_cell)                            \
  1550.   {                                    \
  1551.     remove_lock (set_serializer);                    \
  1552.     cell = new_cell;                            \
  1553.     goto compiler_cache_retry;                        \
  1554.   }                                    \
  1555. }
  1556.  
  1557. #endif /* PARALLEL_PROCESSOR */
  1558.  
  1559. extern SCHEME_OBJECT compiler_cache_variable[];
  1560. extern long
  1561.   EXFUN (compiler_cache,
  1562.      (SCHEME_OBJECT *, SCHEME_OBJECT, SCHEME_OBJECT,
  1563.       SCHEME_OBJECT, long, long, Boolean));
  1564.  
  1565. SCHEME_OBJECT compiler_cache_variable[3];
  1566.  
  1567. Boolean
  1568. DEFUN (local_reference_p, (env, hunk),
  1569.        SCHEME_OBJECT env
  1570.        AND SCHEME_OBJECT * hunk)
  1571. {
  1572.   SCHEME_OBJECT spec;
  1573.  
  1574.   spec = (MEMORY_FETCH (hunk [VARIABLE_COMPILED_TYPE]));
  1575.   switch (OBJECT_TYPE (spec))
  1576.   {
  1577.     case GLOBAL_REF:
  1578.       return (env == (MAKE_OBJECT (GLOBAL_ENV, GO_TO_GLOBAL)));
  1579.  
  1580.     case LOCAL_REF:
  1581.       return (true);
  1582.  
  1583.     case FORMAL_REF:
  1584.     case AUX_REF:
  1585.       return ((OBJECT_DATUM (spec)) == 0);      
  1586.  
  1587.     default:
  1588.       return (false);
  1589.   }
  1590. }
  1591.  
  1592. long
  1593. DEFUN (compiler_cache,
  1594.        (cell, env, name, block, offset, kind, first_time),
  1595.        fast SCHEME_OBJECT * cell
  1596.        AND SCHEME_OBJECT env
  1597.        AND SCHEME_OBJECT name
  1598.        AND SCHEME_OBJECT block
  1599.        AND long offset
  1600.        AND long kind
  1601.        AND Boolean first_time)
  1602. {
  1603.   long EXFUN (cache_reference_end,
  1604.           (long, SCHEME_OBJECT, SCHEME_OBJECT,
  1605.            SCHEME_OBJECT, long, SCHEME_OBJECT));
  1606.  
  1607.   Lock_Handle set_serializer;
  1608.   fast SCHEME_OBJECT trap, references, extension;
  1609.   SCHEME_OBJECT trap_value, store_trap_tag, store_extension;
  1610.   long trap_kind, return_value;
  1611.  
  1612.   store_trap_tag = SHARP_F;
  1613.   store_extension = SHARP_F;
  1614.   trap_kind = TRAP_COMPILER_CACHED;
  1615.  
  1616. compiler_cache_retry:
  1617.  
  1618.   setup_lock (set_serializer, cell);
  1619.   compiler_cache_consistency_check ();
  1620.   compiler_cache_prolog ();
  1621.  
  1622.   trap = *cell;
  1623.   trap_value = trap;
  1624.  
  1625.   if (REFERENCE_TRAP_P (trap))
  1626.   {
  1627.     long old_trap_kind;
  1628.  
  1629.     get_trap_kind (old_trap_kind, trap);
  1630.     switch (old_trap_kind)
  1631.     {
  1632.       case TRAP_UNASSIGNED:
  1633.       case TRAP_UNBOUND:
  1634.       case TRAP_FLUID:
  1635.     break;
  1636.  
  1637.       case TRAP_DANGEROUS:
  1638.         trap_value = (FAST_MEMORY_REF (trap, TRAP_EXTRA));
  1639.     trap_kind = TRAP_COMPILER_CACHED_DANGEROUS;
  1640.     break;
  1641.  
  1642.       case TRAP_UNASSIGNED_DANGEROUS:
  1643.     trap_value = UNASSIGNED_OBJECT;
  1644.     trap_kind = TRAP_COMPILER_CACHED_DANGEROUS;
  1645.     break;
  1646.  
  1647.       case TRAP_UNBOUND_DANGEROUS:
  1648.     trap_value = UNBOUND_OBJECT;
  1649.     trap_kind = TRAP_COMPILER_CACHED_DANGEROUS;
  1650.     break;
  1651.  
  1652.       case TRAP_FLUID_DANGEROUS:
  1653.     store_trap_tag = (LONG_TO_UNSIGNED_FIXNUM (TRAP_FLUID));
  1654.     trap_kind = TRAP_COMPILER_CACHED_DANGEROUS;
  1655.     break;
  1656.  
  1657.       case TRAP_COMPILER_CACHED:
  1658.       case TRAP_COMPILER_CACHED_DANGEROUS:
  1659.     extension = (FAST_MEMORY_REF (trap, TRAP_EXTRA));
  1660.     update_lock (set_serializer,
  1661.              (MEMORY_LOC (extension, TRAP_EXTENSION_CELL)));
  1662.     trap_value = (FAST_MEMORY_REF (extension, TRAP_EXTENSION_CELL));
  1663.     trap_kind = -1;
  1664.     break;
  1665.  
  1666.       default:
  1667.     compiler_cache_epilog ();
  1668.     remove_lock (set_serializer);
  1669.     return (ERR_ILLEGAL_REFERENCE_TRAP);
  1670.     }
  1671.   }
  1672.  
  1673. #if TRUE
  1674.  
  1675.   /* The code below must complete to keep the data structures consistent.
  1676.      Thus instead of checking for GC overflow at each allocation, we check
  1677.      once at the beginning for the maximum amount of space needed.  If we
  1678.      cannot do everything, we interrupt now.  Otherwise, it is assumed
  1679.      that there is enough space available.
  1680.  
  1681.      MAXIMUM_CACHE_SIZE must accomodate the allocation on either
  1682.      branch below, plus potential later allocation (in the form of uuo
  1683.      links).
  1684.  
  1685.      The current value is much larger than what is actually needed, but...
  1686.    */
  1687.  
  1688. #define MAXIMUM_CACHE_SIZE 40
  1689.  
  1690.   if (GC_allocate_test (MAXIMUM_CACHE_SIZE))
  1691.   {
  1692.     compiler_cache_epilog ();
  1693.     remove_lock (set_serializer);
  1694.     Request_GC (MAXIMUM_CACHE_SIZE);
  1695.     return (PRIM_INTERRUPT);
  1696.   }
  1697.  
  1698. #endif
  1699.  
  1700.   /* A new trap is needed.
  1701.      This code could add the new reference to the appropriate list,
  1702.      but instead leaves it to the shared code below because another
  1703.      processor may acquire the lock and change things in the middle
  1704.      of update_lock.
  1705.    */
  1706.  
  1707.   if (trap_kind != -1)
  1708.   {
  1709.     SCHEME_OBJECT new_trap;
  1710.  
  1711. #if FALSE
  1712.     /* This is included in the check above. */
  1713.     if (GC_allocate_test (9))
  1714.     {
  1715.       compiler_cache_epilog ();
  1716.       remove_lock (set_serializer);
  1717.       Request_GC (9);
  1718.       return (PRIM_INTERRUPT);
  1719.     }
  1720. #endif
  1721.  
  1722.     new_trap = (MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, Free));
  1723.     *Free++ = (LONG_TO_UNSIGNED_FIXNUM (trap_kind));
  1724.     extension = (MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE, (Free + 1)));
  1725.     *Free++ = extension;
  1726.  
  1727.     *Free++ = trap_value;
  1728.     *Free++ = name;
  1729.     *Free++ = SHARP_F;
  1730.     references = (MAKE_POINTER_OBJECT (TRAP_REFERENCES_TYPE, (Free + 1)));
  1731.     *Free++ = references;
  1732.  
  1733.     *Free++ = EMPTY_LIST;
  1734.     *Free++ = EMPTY_LIST;
  1735.     *Free++ = EMPTY_LIST;
  1736.  
  1737.     *cell = new_trap;        /* Do_Store_No_Lock ? */
  1738.     if (store_trap_tag != SHARP_F)
  1739.     {
  1740.       /* Do_Store_No_Lock ? */
  1741.       FAST_MEMORY_SET (trap, TRAP_TAG, store_trap_tag);
  1742.     }
  1743.     update_lock (set_serializer,
  1744.          (MEMORY_LOC (extension, TRAP_EXTENSION_CELL)));
  1745.   }
  1746.  
  1747.   if (block == SHARP_F)
  1748.   {
  1749.     /* It is not really from compiled code.
  1750.        The environment linking stuff wants a cc cache instead.
  1751.      */
  1752.     compiler_cache_epilog ();
  1753.     remove_lock (set_serializer);
  1754.     return (PRIM_DONE);
  1755.   }
  1756.  
  1757.   /* There already is a compiled code cache.
  1758.      Maybe this should clean up all the cache lists?
  1759.    */
  1760.  
  1761.   {
  1762.     void fix_references ();
  1763.     long add_reference ();
  1764.  
  1765.     references = (FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES));
  1766.  
  1767.     if (((kind == TRAP_REFERENCES_ASSIGNMENT) &&
  1768.      ((FAST_MEMORY_REF (references, TRAP_REFERENCES_OPERATOR))
  1769.       != EMPTY_LIST)) ||
  1770.     ((kind == TRAP_REFERENCES_OPERATOR) &&
  1771.      ((FAST_MEMORY_REF (references, TRAP_REFERENCES_ASSIGNMENT))
  1772.       != EMPTY_LIST)))
  1773.     {
  1774.       store_extension = (FAST_MEMORY_REF (extension, TRAP_EXTENSION_CLONE));
  1775.       if (store_extension == SHARP_F)
  1776.       {
  1777. #if FALSE
  1778.     /* This is included in the check above. */
  1779.  
  1780.     if (GC_allocate_test (4))
  1781.     {
  1782.       compiler_cache_epilog ();
  1783.       remove_lock (set_serializer);
  1784.       Request_GC (4);
  1785.       return (PRIM_INTERRUPT);
  1786.     }
  1787. #endif
  1788.     store_extension = (MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE, Free));
  1789.     *Free++ = EXPENSIVE_ASSIGNMENT_OBJECT;
  1790.     *Free++ = (FAST_MEMORY_REF (extension, TRAP_EXTENSION_NAME));
  1791.     *Free++ = extension;
  1792.     *Free++ = references;
  1793.     FAST_MEMORY_SET (extension, TRAP_EXTENSION_CLONE, store_extension);
  1794.  
  1795.     if (kind == TRAP_REFERENCES_OPERATOR)
  1796.     {
  1797.       fix_references ((MEMORY_LOC (references,
  1798.                        TRAP_REFERENCES_ASSIGNMENT)),
  1799.               store_extension);
  1800.     }
  1801.       }
  1802.     }
  1803.  
  1804.     /* *UNDEFINE*: If undefine is ever implemented, we should re-think
  1805.        references by fiat since such references have constraints
  1806.        about where they can be linked to.
  1807.        For example, if C -> B -> A (-> means descends from)
  1808.        and there is a reference by fiat from C to B, and we undefine
  1809.        in B, it can go to A, but never to C (or anything between C and B).
  1810.        Curently the only references by fiat are those of the form
  1811.        ((access foo ()) ...)
  1812.      */
  1813.  
  1814.     return_value =
  1815.       (add_reference ((MEMORY_LOC (references, kind)),
  1816.               block,
  1817.               ((local_reference_p (env, compiler_cache_variable))
  1818.                ? (MAKE_OBJECT (TC_CHARACTER, offset))
  1819.                : (MAKE_OBJECT (TC_FIXNUM, offset)))));
  1820.     if (return_value != PRIM_DONE)
  1821.     {
  1822.       compiler_cache_epilog ();
  1823.       remove_lock (set_serializer);
  1824.       return (return_value);
  1825.     }
  1826.   }
  1827.  
  1828.   /* Install an extension or a uuo link in the cc block. */
  1829.  
  1830.   return_value = (cache_reference_end (kind, extension, store_extension,
  1831.                        block, offset, trap_value));
  1832.  
  1833.   /* Unlock and return */
  1834.  
  1835.   compiler_cache_epilog ();
  1836.   remove_lock (set_serializer);
  1837.   return (return_value);
  1838. }
  1839.  
  1840. long
  1841. DEFUN (cache_reference_end,
  1842.        (kind, extension, store_extension, block, offset, value),
  1843.        long kind
  1844.        AND SCHEME_OBJECT extension
  1845.        AND SCHEME_OBJECT store_extension
  1846.        AND SCHEME_OBJECT block
  1847.        AND long offset
  1848.        AND SCHEME_OBJECT value)
  1849. {
  1850.   extern void
  1851.     EXFUN (store_variable_cache, (SCHEME_OBJECT, SCHEME_OBJECT, long));
  1852.   extern long
  1853.     EXFUN (make_fake_uuo_link, (SCHEME_OBJECT, SCHEME_OBJECT, long)),
  1854.     EXFUN (make_uuo_link, (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, long));
  1855.  
  1856.   switch(kind)
  1857.   {
  1858.     default:
  1859.     case TRAP_REFERENCES_ASSIGNMENT:
  1860.       if (store_extension != SHARP_F)
  1861.       {
  1862.     store_variable_cache (store_extension, block, offset);
  1863.     return (PRIM_DONE);
  1864.       }
  1865.       /* Fall through */
  1866.  
  1867.     case TRAP_REFERENCES_LOOKUP:
  1868.       store_variable_cache (extension, block, offset);
  1869.       return (PRIM_DONE);
  1870.  
  1871.     case TRAP_REFERENCES_OPERATOR:
  1872.     {
  1873.       if (REFERENCE_TRAP_P (value))
  1874.       {
  1875.     return (make_fake_uuo_link (extension, block, offset));
  1876.       }
  1877.       else
  1878.       {
  1879.     return (make_uuo_link (value, extension, block, offset));
  1880.       }
  1881.     }
  1882.   }
  1883.   /*NOTREACHED*/
  1884. }
  1885.  
  1886. /* This procedure invokes compiler_cache after finding the top-level
  1887.    value cell associated with (env, name).
  1888.  */
  1889.  
  1890. long
  1891. DEFUN (compiler_cache_reference,
  1892.        (env, name, block, offset, kind, first_time),
  1893.        SCHEME_OBJECT env
  1894.        AND SCHEME_OBJECT name
  1895.        AND SCHEME_OBJECT block
  1896.        AND long offset
  1897.        AND long kind
  1898.        AND Boolean first_time)
  1899. {
  1900.   SCHEME_OBJECT *cell;
  1901.  
  1902.   cell = (deep_lookup (env, name, compiler_cache_variable));
  1903.   if (cell == unbound_trap_object)
  1904.   {
  1905.     long message;
  1906.  
  1907.     cell = (force_definition (env, name, &message));
  1908.     if (message != PRIM_DONE)
  1909.     {
  1910.       return (message);
  1911.     }
  1912.   }
  1913.   return (compiler_cache (cell, env, name, block, offset, kind, first_time));
  1914. }
  1915.  
  1916. /* This procedure updates all the references in the cached reference
  1917.    list pointed at by slot to hold value.  It also eliminates "empty"
  1918.    pairs (pairs whose weakly held block has vanished).
  1919.  */
  1920.  
  1921. void
  1922. DEFUN (fix_references, (slot, extension),
  1923.        fast SCHEME_OBJECT * slot
  1924.        AND fast SCHEME_OBJECT extension)
  1925. {
  1926.   fast SCHEME_OBJECT pair, block;
  1927.  
  1928.   while (*slot != EMPTY_LIST)
  1929.   {
  1930.     pair = (FAST_PAIR_CAR (*slot));
  1931.     block = (FAST_PAIR_CAR (pair));
  1932.     if (block == SHARP_F)
  1933.     {
  1934.       *slot = (FAST_PAIR_CDR (*slot));
  1935.     }
  1936.     else
  1937.     {
  1938.       extern void
  1939.     EXFUN (store_variable_cache, (SCHEME_OBJECT, SCHEME_OBJECT, long));
  1940.  
  1941.       store_variable_cache (extension,
  1942.                 block,
  1943.                 (OBJECT_DATUM (FAST_PAIR_CDR (pair))));
  1944.       slot = (PAIR_CDR_LOC (*slot));
  1945.     }
  1946.   }
  1947.   return;
  1948. }
  1949.  
  1950. /* This procedures adds a new cached reference to the cached reference
  1951.    list pointed at by slot.  It attempts to reuse pairs which have been
  1952.    "emptied" by the garbage collector.
  1953.  */
  1954.  
  1955. long
  1956. DEFUN (add_reference, (slot, block, offset),
  1957.        fast SCHEME_OBJECT * slot
  1958.        AND SCHEME_OBJECT block
  1959.        AND SCHEME_OBJECT offset)
  1960. {
  1961.   fast SCHEME_OBJECT pair;
  1962.  
  1963.   while (*slot != EMPTY_LIST)
  1964.   {
  1965.     pair = (FAST_PAIR_CAR (*slot));
  1966.     if ((FAST_PAIR_CAR (pair)) == SHARP_F)
  1967.     {
  1968.       FAST_SET_PAIR_CAR (pair, block);
  1969.       FAST_SET_PAIR_CDR (pair, offset);
  1970.       return (PRIM_DONE);
  1971.     }
  1972.     slot = (PAIR_CDR_LOC (*slot));
  1973.   }
  1974.  
  1975.   if (GC_allocate_test (4))
  1976.   {
  1977.     Request_GC (4);
  1978.     return (PRIM_INTERRUPT);
  1979.   }
  1980.  
  1981.   *slot = (MAKE_POINTER_OBJECT (TC_LIST, Free));
  1982.   *Free = (MAKE_POINTER_OBJECT (TC_WEAK_CONS, (Free + 2)));
  1983.   Free += 1;
  1984.   *Free++ = EMPTY_LIST;
  1985.  
  1986.   *Free++ = block;
  1987.   *Free++ = offset;
  1988.  
  1989.   return (PRIM_DONE);
  1990. }
  1991.  
  1992. extern SCHEME_OBJECT
  1993.   EXFUN (compiled_block_environment, (SCHEME_OBJECT));
  1994.  
  1995. static long
  1996.   trap_map_table[] = {
  1997.     TRAP_REFERENCES_LOOKUP,
  1998.     TRAP_REFERENCES_ASSIGNMENT,
  1999.     TRAP_REFERENCES_OPERATOR
  2000.     };
  2001.  
  2002. #define TRAP_MAP_TABLE_SIZE (sizeof(trap_map_table) / sizeof(long))
  2003.  
  2004. #ifndef DEFINITION_RECACHES_EAGERLY
  2005.  
  2006. /* compiler_uncache_slot uncaches all references in the list pointed
  2007.    at by slot, and clears the list.  If the references are operator
  2008.    references, a fake compiled procedure which will recache when
  2009.    invoked is created and installed.
  2010.  */
  2011.  
  2012. long
  2013. DEFUN (compiler_uncache_slot, (slot, sym, kind),
  2014.        fast SCHEME_OBJECT * slot
  2015.        AND SCHEME_OBJECT sym
  2016.        AND long kind)
  2017. {
  2018.   fast SCHEME_OBJECT temp, pair;
  2019.   SCHEME_OBJECT block, offset, new_extension;
  2020.  
  2021.   for (temp = *slot; temp != EMPTY_LIST; temp = *slot)
  2022.   {
  2023.     pair = (FAST_PAIR_CAR (temp));
  2024.     block = (FAST_PAIR_CAR (pair));
  2025.     if (block != SHARP_F)
  2026.     {
  2027.       offset = (FAST_PAIR_CDR (pair));
  2028.       if (CHARACTER_P (offset))
  2029.       {
  2030.     /* This reference really belongs here! -- do not uncache.
  2031.        Skip to next.
  2032.      */
  2033.  
  2034.     slot = (PAIR_CDR_LOC (temp));
  2035.     continue;
  2036.       }
  2037.       else
  2038.       {
  2039.     if (GC_allocate_test (4))
  2040.     {
  2041.       Request_GC (4);
  2042.       return (PRIM_INTERRUPT);
  2043.     }
  2044.     new_extension = (MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE, Free));
  2045.     *Free++ = REQUEST_RECACHE_OBJECT;
  2046.     *Free++ = sym;
  2047.     *Free++ = block;
  2048.     *Free++ = offset;
  2049.  
  2050.     if (kind == TRAP_REFERENCES_OPERATOR)
  2051.     {
  2052.       extern long
  2053.         EXFUN (make_fake_uuo_link, (SCHEME_OBJECT, SCHEME_OBJECT, long));
  2054.       long result;
  2055.  
  2056.       result = (make_fake_uuo_link (new_extension,
  2057.                     block,
  2058.                     (OBJECT_DATUM (offset))));
  2059.       if (result != PRIM_DONE)
  2060.         return (result);
  2061.     }
  2062.     else
  2063.     {
  2064.       extern void
  2065.         EXFUN (store_variable_cache, (SCHEME_OBJECT, SCHEME_OBJECT, long));
  2066.  
  2067.       store_variable_cache (new_extension, block, (OBJECT_DATUM (offset)));
  2068.     }
  2069.       }
  2070.     }
  2071.     *slot = (FAST_PAIR_CDR (temp));
  2072.   }
  2073.   return (PRIM_DONE);
  2074. }
  2075.  
  2076. /* compiler_uncache is invoked when a redefinition occurs.
  2077.    It uncaches all references cached to this value cell, and
  2078.    sets the variables up to be recached at the next reference.
  2079.    value_cell is the value cell being shadowed.
  2080.    sym is the name of the variable.
  2081.  */
  2082.  
  2083. long
  2084. DEFUN (compiler_uncache, (value_cell, sym),
  2085.        SCHEME_OBJECT * value_cell
  2086.        AND SCHEME_OBJECT sym)
  2087. {
  2088.   Lock_Handle set_serializer;
  2089.   SCHEME_OBJECT val, extension, references;
  2090.   long trap_kind, temp, i, index;
  2091.  
  2092.   setup_lock (set_serializer, value_cell);
  2093.  
  2094.   val = *value_cell;
  2095.  
  2096.   if (!(REFERENCE_TRAP_P (val)))
  2097.   {
  2098.     remove_lock (set_serializer);
  2099.     return (PRIM_DONE);
  2100.   }
  2101.  
  2102.   get_trap_kind (trap_kind, val);
  2103.   if ((trap_kind != TRAP_COMPILER_CACHED) &&
  2104.       (trap_kind != TRAP_COMPILER_CACHED_DANGEROUS))
  2105.   {
  2106.     remove_lock (set_serializer);
  2107.     return (PRIM_DONE);
  2108.   }
  2109.  
  2110.   compiler_uncache_prolog ();
  2111.  
  2112.   extension = (FAST_MEMORY_REF (val, TRAP_EXTRA));
  2113.   references = (FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES));
  2114.   update_lock (set_serializer, (MEMORY_LOC (extension, TRAP_EXTENSION_CELL)));
  2115.  
  2116.   /* Uncache all of the lists. */
  2117.  
  2118.   for (i = TRAP_MAP_TABLE_SIZE; --i >= 0; )
  2119.   {
  2120.     index = trap_map_table[i];
  2121.     temp = (compiler_uncache_slot ((MEMORY_LOC (references, index)),
  2122.                    sym, index));
  2123.     if (temp != PRIM_DONE)
  2124.     {
  2125.       remove_lock (set_serializer);
  2126.       compiler_uncache_epilog ();
  2127.       return (temp);
  2128.     }
  2129.   }
  2130.  
  2131.   /* Note that we can only remove the trap if no references remain,
  2132.      ie. if there were no hard-wired references to this frame.
  2133.      We can test that by checking whether all the slots were set
  2134.      to EMPTY_LIST in the preceding loop.
  2135.      The current code, however, never removes the trap.
  2136.    */
  2137.  
  2138.   /* Remove the clone extension if there is one and it is no longer needed. */
  2139.  
  2140.   if ((FAST_MEMORY_REF (extension, TRAP_EXTENSION_CLONE)) != SHARP_F)
  2141.   {
  2142.     if ((FAST_MEMORY_REF (references, TRAP_REFERENCES_ASSIGNMENT))
  2143.     == EMPTY_LIST)
  2144.     {
  2145.       FAST_MEMORY_SET (extension, TRAP_EXTENSION_CLONE, SHARP_F);
  2146.     }
  2147.     else if ((FAST_MEMORY_REF (references, TRAP_REFERENCES_OPERATOR))
  2148.          == EMPTY_LIST)
  2149.     {
  2150.       /* All operators have disappeared, we can remove the clone,
  2151.      but we must update the cells.
  2152.        */
  2153.       fix_references ((MEMORY_LOC (references, TRAP_REFERENCES_ASSIGNMENT)),
  2154.               extension);
  2155.       FAST_MEMORY_SET (extension, TRAP_EXTENSION_CLONE, SHARP_F);
  2156.     }
  2157.   }
  2158.   compiler_uncache_epilog ();
  2159.   remove_lock (set_serializer);
  2160.   return (PRIM_DONE);
  2161. }
  2162.  
  2163. #endif /* DEFINITION_RECACHES_EAGERLY */
  2164.  
  2165. #ifdef DEFINITION_RECACHES_EAGERLY
  2166.  
  2167. /*
  2168.    compiler_recache is invoked when a redefinition occurs.  It
  2169.    recaches (at the definition point) all the references that need to
  2170.    point to the new cell.
  2171.  
  2172.    It does this in two phases:
  2173.  
  2174.    - First (by means of compiler_recache_split) it splits all
  2175.    references into those that need to be updated and those that do
  2176.    not.  This is done by side-effecting the list so that all those
  2177.    that need updating are at the end, and when we actually decide to
  2178.    go ahead, we can just clip it and install it in the new location.
  2179.    compiler_recache_split also counts how many entries are affected,
  2180.    so the total amount of gc space needed can be computed.
  2181.  
  2182.    - After checking that there is enough space to proceed, (rather
  2183.    than aborting) it actually does the recaching.  It caches to the
  2184.    new location/value by using compiler_recache_slot.  Note that the
  2185.    eventual trap extension has already been allocated so the recached
  2186.    links can point to it.
  2187.  */
  2188.  
  2189. /* Required by compiler_uncache macro. */
  2190.  
  2191. SCHEME_OBJECT *shadowed_value_cell = ((SCHEME_OBJECT *) NULL);
  2192.  
  2193. /* Each extension is a hunk4. */
  2194.  
  2195. #define SPACE_PER_EXTENSION    4
  2196.  
  2197. /* Trap, extension, and one cache-list hunk. */
  2198.  
  2199. #define SPACE_PER_TRAP        (2 + SPACE_PER_EXTENSION + 3)
  2200.  
  2201. /* 1 Pair and 1 Weak pair.
  2202.    Not really needed since the pairs and weak pairs are reused.
  2203.  */
  2204.  
  2205. #define SPACE_PER_ENTRY        (2 + 2)
  2206.  
  2207. /* Hopefully a conservative guesstimate. */
  2208.  
  2209. #ifndef SPACE_PER_LINK        /* So it can be overriden from config.h */
  2210. #define SPACE_PER_LINK        10
  2211. #endif
  2212.  
  2213. /* The spaces are 0 because the pairs are reused!  If that ever changes,
  2214.    they should all become SPACE_PER_ENTRY + curent value.
  2215.  */
  2216.  
  2217. #define SPACE_PER_LOOKUP    0
  2218. #define SPACE_PER_ASSIGNMENT    0
  2219. #define SPACE_PER_OPERATOR    (0 + SPACE_PER_LINK)
  2220.  
  2221. static long
  2222.   trap_size_table[TRAP_MAP_TABLE_SIZE] = {
  2223.     SPACE_PER_LOOKUP,
  2224.     SPACE_PER_ASSIGNMENT,
  2225.     SPACE_PER_OPERATOR
  2226.     };
  2227.  
  2228. static long
  2229.   trap_conflict_table[TRAP_MAP_TABLE_SIZE] = {
  2230.     0,                /* lookup */
  2231.     1,                /* assignment */
  2232.     1                /* operator */
  2233.     };
  2234.  
  2235. Boolean
  2236. DEFUN (environment_ancestor_or_self_p, (ancestor, descendant),
  2237.        fast SCHEME_OBJECT ancestor
  2238.        AND fast SCHEME_OBJECT descendant)
  2239. {
  2240.   while ((OBJECT_TYPE (descendant)) != GLOBAL_ENV)
  2241.   {
  2242.     if (descendant == ancestor)
  2243.       return (true);
  2244.     descendant = (FAST_MEMORY_REF ((MEMORY_REF (descendant,
  2245.                         ENVIRONMENT_FUNCTION)),
  2246.                    PROCEDURE_ENVIRONMENT));
  2247.   }
  2248.   return (descendant == ancestor);
  2249. }
  2250.  
  2251. /* This reorders the entries in slot so that the entries that are
  2252.    not affected by the redefinition appear first, and the affected
  2253.    ones appear last.  A pointer to the first affected cell is stored
  2254.    in memoize_cell, and this will be given to compiler_recache_slot
  2255.    in order to avoid recomputing the division.
  2256.  
  2257.    Note: There is an implicit assumption throughout that none of the
  2258.    pairs (or weak pairs) are in pure space.  If they are, they cannot
  2259.    be sorted or reused.
  2260.  */
  2261.  
  2262. long
  2263. DEFUN (compiler_recache_split,
  2264.        (slot, sym, definition_env, memoize_cell, link_p),
  2265.        fast SCHEME_OBJECT * slot
  2266.        AND SCHEME_OBJECT sym
  2267.        AND SCHEME_OBJECT definition_env
  2268.        AND SCHEME_OBJECT ** memoize_cell
  2269.        AND Boolean link_p)
  2270. {
  2271.   fast long count;
  2272.   SCHEME_OBJECT weak_pair, block, reference_env, invalid_head;
  2273.   fast SCHEME_OBJECT *last_invalid;
  2274.  
  2275.   count = 0;
  2276.   last_invalid = &invalid_head;
  2277.  
  2278.   while (*slot != EMPTY_LIST)
  2279.   {
  2280.     weak_pair = (FAST_PAIR_CAR (*slot));
  2281.     block = (FAST_PAIR_CAR (weak_pair));
  2282.     if (block == SHARP_F)
  2283.     {
  2284.       *slot = (FAST_PAIR_CDR (*slot));
  2285.       continue;
  2286.     }
  2287.     if (!link_p && (CHARACTER_P (FAST_PAIR_CDR (weak_pair))))
  2288.     {
  2289.       /* The reference really belongs here -- it is not affected by fiat. */
  2290.       slot = (PAIR_CDR_LOC (*slot));
  2291.     }
  2292.     else
  2293.     {
  2294.       reference_env = (compiled_block_environment (block));
  2295.       if (!environment_ancestor_or_self_p (definition_env, reference_env))
  2296.       {
  2297.     slot = (PAIR_CDR_LOC (*slot));
  2298.       }
  2299.       else
  2300.       {
  2301.     count += 1;
  2302.     *last_invalid = *slot;
  2303.     last_invalid = (PAIR_CDR_LOC (*slot));
  2304.     *slot = *last_invalid;
  2305.       }
  2306.     }
  2307.   }
  2308.   *last_invalid = EMPTY_LIST;
  2309.   *memoize_cell = slot;
  2310.   *slot = invalid_head;
  2311.   return (count);
  2312. }
  2313.  
  2314. /* This recaches the entries pointed out by cell and adds them
  2315.    to the list in slot.  It also sets to #F the contents
  2316.    of cell.
  2317.  
  2318.    Note that this reuses the pairs and weak pairs that used to be
  2319.    in cell.
  2320.  */
  2321.  
  2322. long
  2323. DEFUN (compiler_recache_slot,
  2324.        (extension, sym, kind, slot, cell, value),
  2325.        SCHEME_OBJECT extension
  2326.        AND SCHEME_OBJECT sym
  2327.        AND long kind
  2328.        AND fast SCHEME_OBJECT * slot
  2329.        AND fast SCHEME_OBJECT * cell
  2330.        AND SCHEME_OBJECT value)
  2331. {
  2332.   fast SCHEME_OBJECT pair, weak_pair;
  2333.   SCHEME_OBJECT clone, tail;
  2334.   long result;
  2335.  
  2336.   /* This is #F if there isn't one.
  2337.      This makes cache_reference_end do the right thing.
  2338.    */
  2339.   clone = (FAST_MEMORY_REF (extension, TRAP_EXTENSION_CLONE));
  2340.   tail = *slot;
  2341.  
  2342.   for (pair = *cell; pair != NULL; pair = *cell)
  2343.   {
  2344.     weak_pair = (FAST_PAIR_CAR (pair));
  2345.     result = (cache_reference_end (kind, extension, clone,
  2346.                    (FAST_PAIR_CAR (weak_pair)),
  2347.                    (OBJECT_DATUM (FAST_PAIR_CDR (weak_pair))),
  2348.                    value));
  2349.     if (result != PRIM_DONE)
  2350.     {
  2351.       /* We are severely screwed.
  2352.      compiler_recache will do the appropriate thing.
  2353.        */
  2354.       *slot = tail;
  2355.       return (result);
  2356.     }
  2357.  
  2358.     *slot = pair;
  2359.     slot = (PAIR_CDR_LOC (pair));
  2360.     *cell = *slot;
  2361.   }
  2362.   *slot = tail;
  2363.   return (PRIM_DONE);
  2364. }
  2365.  
  2366. long
  2367. DEFUN (compiler_recache,
  2368.        (old_value_cell, new_value_cell, env, sym, value, shadowed_p, link_p),
  2369.        SCHEME_OBJECT * old_value_cell
  2370.        AND SCHEME_OBJECT * new_value_cell
  2371.        AND SCHEME_OBJECT env
  2372.        AND SCHEME_OBJECT sym
  2373.        AND SCHEME_OBJECT value
  2374.        AND Boolean shadowed_p
  2375.        AND Boolean link_p)
  2376. {
  2377.   Lock_Handle set_serializer_1, set_serializer_2;
  2378.   SCHEME_OBJECT
  2379.     old_value, references, extension, new_extension, new_trap,
  2380.     *trap_info_table[TRAP_MAP_TABLE_SIZE];
  2381.   long
  2382.     trap_kind, temp, i, index, total_size, total_count, conflict_count;
  2383.  
  2384.   setup_locks (set_serializer_1, old_value_cell,
  2385.            set_serializer_2, new_value_cell);
  2386.  
  2387.   if ((!link_p) && (*new_value_cell != DANGEROUS_UNBOUND_OBJECT))
  2388.   {
  2389.     /* Another processor has redefined this word in the meantime.
  2390.        The other processor must have recached all the compiled code
  2391.        caches since it is shadowing the same variable.
  2392.        The definition has become a redefinition.
  2393.      */
  2394.     remove_locks (set_serializer_1, set_serializer_2);
  2395.     return (redefinition (new_value_cell, value));
  2396.   }
  2397.  
  2398.   old_value = *old_value_cell;
  2399.  
  2400.   if (!(REFERENCE_TRAP_P (old_value)))
  2401.   {
  2402.     remove_locks (set_serializer_1, set_serializer_2);
  2403.     return (link_p ?
  2404.         PRIM_DONE :
  2405.         (definition (new_value_cell, value, shadowed_p)));
  2406.   }
  2407.  
  2408.   get_trap_kind (trap_kind, old_value);
  2409.   if ((trap_kind != TRAP_COMPILER_CACHED) &&
  2410.       (trap_kind != TRAP_COMPILER_CACHED_DANGEROUS))
  2411.   {
  2412.     remove_locks (set_serializer_1, set_serializer_2);
  2413.     return (link_p ?
  2414.         PRIM_DONE :
  2415.         (definition (new_value_cell, value, shadowed_p)));
  2416.   }
  2417.  
  2418.   compiler_recache_prolog ();
  2419.  
  2420.   extension = (FAST_MEMORY_REF (old_value, TRAP_EXTRA));
  2421.   references = (FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES));
  2422.   update_lock (set_serializer_1,
  2423.            (MEMORY_LOC (extension, TRAP_EXTENSION_CELL)));
  2424.  
  2425.   /*
  2426.      Split each slot and compute the amount to allocate.
  2427.    */
  2428.  
  2429.   conflict_count = 0;
  2430.   total_size = (link_p ? 0 : SPACE_PER_TRAP);
  2431.   total_count = 0;
  2432.  
  2433.   for (i = TRAP_MAP_TABLE_SIZE; --i >= 0; )
  2434.   {
  2435.     index = trap_map_table[i];
  2436.     temp = compiler_recache_split ((MEMORY_LOC (references, index)),
  2437.                    sym, env, &trap_info_table[i], link_p);
  2438.  
  2439.     if (temp != 0)
  2440.     {
  2441.       conflict_count += trap_conflict_table[i];
  2442.       total_size += (temp * trap_size_table[i]);
  2443.       total_count += temp;
  2444.     }
  2445.   }
  2446.  
  2447.   if (total_count == 0)
  2448.   {
  2449.     compiler_recache_epilog ();
  2450.     remove_locks (set_serializer_1, set_serializer_2);
  2451.     return (link_p ?
  2452.         PRIM_DONE :
  2453.         (definition (new_value_cell, value, shadowed_p)));
  2454.   }
  2455.  
  2456.   if ((conflict_count == 2) &&
  2457.       ((!link_p) ||
  2458.        (new_value_cell[TRAP_EXTENSION_CLONE] == SHARP_F)))
  2459.   {
  2460.     total_size += SPACE_PER_EXTENSION;
  2461.   }
  2462.  
  2463.   if (GC_allocate_test (total_size))
  2464.   {
  2465.     /* Unfortunate fact of life: This binding will be dangerous
  2466.        even if there is no need, but this is the only way to
  2467.        guarantee consistent values.
  2468.      */
  2469.     compiler_recache_epilog ();
  2470.     remove_locks (set_serializer_1, set_serializer_2);
  2471.     Request_GC (total_size);
  2472.     return (PRIM_INTERRUPT);
  2473.   }
  2474.  
  2475.   /*
  2476.      Allocate and initialize all the cache structures if necessary.
  2477.    */
  2478.  
  2479.   if (link_p)
  2480.   {
  2481.     new_extension = (MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE, new_value_cell));
  2482.     references = new_value_cell[TRAP_EXTENSION_REFERENCES];
  2483.   }
  2484.   else
  2485.   {
  2486.     /* The reference trap is created here, but is not installed in the
  2487.        environment structure until the end.  The new binding contains
  2488.        a DANGEROUS_UNBOUND_OBJECT so that other parallel lookups will
  2489.        skip this binding.
  2490.      */
  2491.  
  2492.     references = (MAKE_POINTER_OBJECT (TRAP_REFERENCES_TYPE, Free));
  2493.  
  2494.     *Free++ = EMPTY_LIST;
  2495.     *Free++ = EMPTY_LIST;
  2496.     *Free++ = EMPTY_LIST;
  2497.  
  2498.     new_extension = (MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE, Free));
  2499.  
  2500.     *Free++ = value;
  2501.     *Free++ = sym;
  2502.     *Free++ = SHARP_F;
  2503.     *Free++ = references;
  2504.  
  2505.     new_trap = (MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, Free));
  2506.     *Free++ = (LONG_TO_UNSIGNED_FIXNUM ((shadowed_p ?
  2507.                      TRAP_COMPILER_CACHED_DANGEROUS :
  2508.                      TRAP_COMPILER_CACHED)));
  2509.     *Free++ = new_extension;
  2510.   }
  2511.  
  2512.   if ((conflict_count == 2) &&
  2513.       (MEMORY_REF (new_extension, TRAP_EXTENSION_CLONE) == SHARP_F))
  2514.   {
  2515.     SCHEME_OBJECT clone;
  2516.  
  2517.     clone = (MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE, Free));
  2518.  
  2519.     *Free++ = EXPENSIVE_ASSIGNMENT_OBJECT;
  2520.     *Free++ = sym;
  2521.     *Free++ = new_extension;
  2522.     *Free++ = references;
  2523.     FAST_MEMORY_SET (new_extension, TRAP_EXTENSION_CLONE, clone);
  2524.   }
  2525.  
  2526.   /*
  2527.      Now we actually perform the recaching, allocating freely.
  2528.    */
  2529.  
  2530.   for (i = TRAP_MAP_TABLE_SIZE; --i >= 0; )
  2531.   {
  2532.     index = trap_map_table[i];
  2533.     temp = (compiler_recache_slot (new_extension, sym, index,
  2534.                    (MEMORY_LOC (references, index)),
  2535.                    trap_info_table[i],
  2536.                    value));
  2537.     if (temp != PRIM_DONE)
  2538.     {
  2539.       extern char *Abort_Names[];
  2540.  
  2541.       /* We've lost BIG. */
  2542.  
  2543.       if (temp == PRIM_INTERRUPT)
  2544.     fprintf (stderr,
  2545.          "\ncompiler_recache: Ran out of guaranteed space!\n");
  2546.       else if (temp > 0)
  2547.     fprintf (stderr,
  2548.          "\ncompiler_recache: Unexpected error value %d (%s)\n",
  2549.          temp, Abort_Names[temp]);
  2550.       else
  2551.     fprintf (stderr,
  2552.          "\ncompiler_recache: Unexpected abort value %d (%s)\n",
  2553.          -temp, Abort_Names[(-temp) - 1]);
  2554.       Microcode_Termination (TERM_EXIT);
  2555.     }
  2556.   }
  2557.  
  2558.   if (!link_p)
  2559.   {
  2560.     *new_value_cell = new_trap;
  2561.   }
  2562.   compiler_recache_epilog ();
  2563.   remove_locks (set_serializer_1, set_serializer_2);
  2564.   return (PRIM_DONE);
  2565. }
  2566.  
  2567. #endif /* DEFINITION_RECACHES_EAGERLY */
  2568.  
  2569. /* recache_uuo_links is invoked when an assignment occurs to a
  2570.    variable which has cached operator references (uuo links).
  2571.    All the operator references must be recached to the new value.
  2572.  
  2573.    It currently potentially creates a new uuo link per operator
  2574.    reference.  This may be very expensive in space, but allows a great
  2575.    deal of flexibility.  It is ultimately necessary if there is hidden
  2576.    information on each call (like arity, types of arguments, etc.).
  2577.  */
  2578.  
  2579. long
  2580. DEFUN (recache_uuo_links, (extension, old_value),
  2581.        SCHEME_OBJECT extension
  2582.        AND SCHEME_OBJECT old_value)
  2583. {
  2584.   long EXFUN (update_uuo_links,
  2585.           (SCHEME_OBJECT, SCHEME_OBJECT,
  2586.            long ((*)(SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, long))));
  2587.  
  2588.   SCHEME_OBJECT value;
  2589.   long return_value;
  2590.  
  2591.   value = (FAST_MEMORY_REF (extension, TRAP_EXTENSION_CELL));
  2592.   if (REFERENCE_TRAP_P (value))
  2593.   {
  2594.     if (REFERENCE_TRAP_P (old_value))
  2595.     {
  2596.       /* No need to do anything.
  2597.      The uuo links are in the correct state.
  2598.        */
  2599.  
  2600.       return_value = PRIM_DONE;
  2601.     }
  2602.     else
  2603.     {
  2604.       long EXFUN (make_recache_uuo_link,
  2605.           (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, long));
  2606.  
  2607.       return_value =
  2608.     update_uuo_links (value, extension, make_recache_uuo_link);
  2609.     }
  2610.   }
  2611.   else
  2612.   {
  2613.     extern long
  2614.       EXFUN (make_uuo_link,
  2615.          (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, long));
  2616.  
  2617.     return_value =
  2618.       update_uuo_links (value, extension, make_uuo_link);
  2619.   }
  2620.  
  2621.   if (return_value != PRIM_DONE)
  2622.   {
  2623.     /*
  2624.        This reverts the variable's value to the original value except
  2625.        when the value was fluid bound.  In the latter case, it does
  2626.        not matter, it should still work: When the assignment is
  2627.        restarted, and recache_uuo_links is restarted, the relative
  2628.        "trapness" of both old and new values should be unchanged.
  2629.  
  2630.        Note that recache_uuo_links is invoked with the cell locked,
  2631.        so it is safe to "revert" the value.
  2632.      */
  2633.  
  2634.     FAST_MEMORY_SET (extension, TRAP_EXTENSION_CELL, old_value);
  2635.   }
  2636.   return (return_value);
  2637. }
  2638.  
  2639. /* This kludge is due to the lack of closures. */
  2640.  
  2641. long
  2642. DEFUN (make_recache_uuo_link, (value, extension, block, offset),
  2643.        SCHEME_OBJECT value
  2644.        AND SCHEME_OBJECT extension
  2645.        AND SCHEME_OBJECT block
  2646.        AND long offset)
  2647. {
  2648.   extern long
  2649.     EXFUN (make_fake_uuo_link, (SCHEME_OBJECT, SCHEME_OBJECT, long));
  2650.  
  2651.   return (make_fake_uuo_link (extension, block, offset));
  2652. }
  2653.  
  2654. long
  2655. DEFUN (update_uuo_links,
  2656.        (value, extension, handler),
  2657.        SCHEME_OBJECT value
  2658.        AND SCHEME_OBJECT extension
  2659.        AND long EXFUN ((*handler),
  2660.                (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, long)))
  2661. {
  2662.   SCHEME_OBJECT references, pair, block;
  2663.   fast SCHEME_OBJECT *slot;
  2664.   long return_value;
  2665.  
  2666.   update_uuo_prolog();
  2667.   references = (FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES));
  2668.   slot = (MEMORY_LOC (references, TRAP_REFERENCES_OPERATOR));
  2669.  
  2670.   while (*slot != EMPTY_LIST)
  2671.   {
  2672.     pair = (FAST_PAIR_CAR (*slot));
  2673.     block = (FAST_PAIR_CAR (pair));
  2674.     if (block == SHARP_F)
  2675.     {
  2676.       *slot = (FAST_PAIR_CDR (*slot));
  2677.     }
  2678.     else
  2679.     {
  2680.       return_value =
  2681.     (*handler)(value, extension, block,
  2682.            (OBJECT_DATUM (FAST_PAIR_CDR (pair))));
  2683.       if (return_value != PRIM_DONE)
  2684.       {
  2685.     update_uuo_epilog ();
  2686.     return (return_value);
  2687.       }
  2688.       slot = (PAIR_CDR_LOC (*slot));
  2689.     }
  2690.   }
  2691.  
  2692.   /* If there are no uuo links left, and there is an extension clone,
  2693.      remove it, and make assignment references point to the real value
  2694.      cell.
  2695.    */
  2696.  
  2697.   if ((FAST_MEMORY_REF (references, TRAP_REFERENCES_OPERATOR) == EMPTY_LIST) &&
  2698.       (FAST_MEMORY_REF (extension, TRAP_EXTENSION_CLONE) != SHARP_F))
  2699.   {
  2700.     FAST_MEMORY_SET (extension, TRAP_EXTENSION_CLONE, SHARP_F);
  2701.     fix_references ((MEMORY_LOC (references, TRAP_REFERENCES_ASSIGNMENT)),
  2702.             extension);
  2703.   }
  2704.   update_uuo_epilog ();
  2705.   return (PRIM_DONE);
  2706. }
  2707.  
  2708. /* compiler_reference_trap is called when a reference occurs to a compiled
  2709.    reference cache which contains a reference trap.  If the trap is
  2710.    the special REQUEST_RECACHE_OBJECT, the reference is recached.
  2711.    Otherwise the reference is done normally, and the process continued.
  2712.  */
  2713.  
  2714. long
  2715. DEFUN (compiler_reference_trap, (extension, kind, handler),
  2716.        SCHEME_OBJECT extension
  2717.        AND long kind
  2718.        AND long EXFUN ((*handler),(SCHEME_OBJECT *, SCHEME_OBJECT *)))
  2719. {
  2720.   long offset, temp;
  2721.   SCHEME_OBJECT block;
  2722.  
  2723. try_again:
  2724.  
  2725.   if ((MEMORY_REF (extension, TRAP_EXTENSION_CELL)) != REQUEST_RECACHE_OBJECT)
  2726.   {
  2727.     return ((*handler) (MEMORY_LOC (extension, TRAP_EXTENSION_CELL),
  2728.             fake_variable_object));
  2729.   }
  2730.  
  2731.   block = (FAST_MEMORY_REF (extension, TRAP_EXTENSION_BLOCK));
  2732.   offset = (OBJECT_DATUM (FAST_MEMORY_REF (extension, TRAP_EXTENSION_OFFSET)));
  2733.  
  2734.   compiler_trap_prolog ();
  2735.   temp =
  2736.     (compiler_cache_reference ((compiled_block_environment (block)),
  2737.                    (FAST_MEMORY_REF (extension,
  2738.                          TRAP_EXTENSION_NAME)),
  2739.                    block, offset, kind, false));
  2740.   compiler_trap_epilog ();
  2741.   if (temp != PRIM_DONE)
  2742.   {
  2743.     return (temp);
  2744.   }
  2745.  
  2746.   switch (kind)
  2747.   {
  2748.     case TRAP_REFERENCES_OPERATOR:
  2749.     {
  2750.  
  2751.       /* Note that this value may cause another operator trap when
  2752.      invoked, since it may be a uuo-link to an interpreted
  2753.      procedure, or to a variable with a trap in it.  However, it
  2754.      should not go into a loop because the reference should be
  2755.      cached to the correct place, so the extension will no longer
  2756.      have a REQUEST_RECACHE_OBJECT in it.  The first branch in
  2757.      this procedure will be taken in this case.  On a
  2758.      multiprocessor it may in fact loop if some other processor
  2759.      redefines the variable before we have a chance to invoke the
  2760.      value.
  2761.        */
  2762.  
  2763.       extern SCHEME_OBJECT
  2764.     EXFUN (extract_uuo_link, (SCHEME_OBJECT, long));
  2765.  
  2766.       Val = (extract_uuo_link (block, offset));
  2767.       return (PRIM_DONE);
  2768.     }
  2769.  
  2770.     case TRAP_REFERENCES_ASSIGNMENT:
  2771.     case TRAP_REFERENCES_LOOKUP:
  2772.     default:
  2773.     {
  2774.       extern SCHEME_OBJECT
  2775.     EXFUN (extract_variable_cache, (SCHEME_OBJECT, long));
  2776.  
  2777.       extension = (extract_variable_cache (block, offset));
  2778.       /* This is paranoid on a single processor, but it does not hurt.
  2779.      On a multiprocessor, we need to do it because some other processor
  2780.      may have redefined this variable in the meantime.
  2781.        */
  2782.       goto try_again;
  2783.     }
  2784.   }
  2785. }
  2786.  
  2787. /* Procedures invoked from the compiled code interface. */
  2788.  
  2789. extern long
  2790.   EXFUN (compiler_cache_lookup, (SCHEME_OBJECT, SCHEME_OBJECT, long)),
  2791.   EXFUN (compiler_cache_assignment, (SCHEME_OBJECT, SCHEME_OBJECT, long)),
  2792.   EXFUN (compiler_cache_operator, (SCHEME_OBJECT, SCHEME_OBJECT, long)),
  2793.   EXFUN (compiler_cache_global_operator, (SCHEME_OBJECT, SCHEME_OBJECT, long));
  2794.  
  2795. long
  2796. DEFUN (compiler_cache_lookup, (name, block, offset),
  2797.        SCHEME_OBJECT name
  2798.        AND SCHEME_OBJECT block
  2799.        AND long offset)
  2800. {
  2801.   return (compiler_cache_reference ((compiled_block_environment (block)),
  2802.                     name, block, offset,
  2803.                     TRAP_REFERENCES_LOOKUP, true));
  2804. }
  2805.  
  2806. long
  2807. DEFUN (compiler_cache_assignment, (name, block, offset),
  2808.        SCHEME_OBJECT name
  2809.        AND SCHEME_OBJECT block
  2810.        AND long offset)
  2811. {
  2812.   return (compiler_cache_reference ((compiled_block_environment (block)),
  2813.                     name, block, offset,
  2814.                     TRAP_REFERENCES_ASSIGNMENT, true));
  2815. }
  2816.  
  2817. long
  2818. DEFUN (compiler_cache_operator, (name, block, offset),
  2819.        SCHEME_OBJECT name
  2820.        AND SCHEME_OBJECT block
  2821.        AND long offset)
  2822. {
  2823.   return (compiler_cache_reference ((compiled_block_environment (block)),
  2824.                     name, block, offset,
  2825.                     TRAP_REFERENCES_OPERATOR, true));
  2826. }
  2827.  
  2828. long
  2829. DEFUN (compiler_cache_global_operator, (name, block, offset),
  2830.        SCHEME_OBJECT name
  2831.        AND SCHEME_OBJECT block
  2832.        AND long offset)
  2833. {
  2834.   return (compiler_cache_reference ((MAKE_OBJECT (GLOBAL_ENV, GO_TO_GLOBAL)),
  2835.                     name, block, offset,
  2836.                     TRAP_REFERENCES_OPERATOR, true));
  2837. }
  2838.  
  2839. extern long
  2840.   EXFUN (complr_operator_reference_trap, (SCHEME_OBJECT *, SCHEME_OBJECT));
  2841.  
  2842. extern SCHEME_OBJECT
  2843.   EXFUN (compiler_var_error, (SCHEME_OBJECT, SCHEME_OBJECT));
  2844.  
  2845. long
  2846. DEFUN (complr_operator_reference_trap, (frame_slot, extension),
  2847.        SCHEME_OBJECT * frame_slot
  2848.        AND SCHEME_OBJECT extension)
  2849. {
  2850.   long temp;
  2851.  
  2852.   temp = (compiler_reference_trap (extension,
  2853.                    TRAP_REFERENCES_OPERATOR,
  2854.                    deep_lookup_end));
  2855.   if (temp != PRIM_DONE)
  2856.   {
  2857.     return temp;
  2858.   }
  2859.   *frame_slot = Val;
  2860.   return (PRIM_DONE);
  2861. }
  2862.  
  2863. SCHEME_OBJECT
  2864. DEFUN (compiler_var_error, (extension, environment),
  2865.        SCHEME_OBJECT extension
  2866.        AND SCHEME_OBJECT environment)
  2867. {
  2868.   return (MEMORY_REF (extension, TRAP_EXTENSION_NAME));
  2869. }
  2870.  
  2871. /* Utility for compiler_assignment_trap, below.
  2872.    Necessary because C lacks lambda.  Argh!
  2873.  */
  2874.  
  2875. static SCHEME_OBJECT saved_compiler_assignment_value;
  2876.  
  2877. long
  2878. DEFUN (compiler_assignment_end, (cell, hunk),
  2879.        SCHEME_OBJECT * cell
  2880.        AND SCHEME_OBJECT * hunk)
  2881. {
  2882.   return (deep_assignment_end (cell, hunk,
  2883.                    saved_compiler_assignment_value, false));
  2884. }
  2885.  
  2886. /* More compiled code interface procedures */
  2887.  
  2888. extern long
  2889.   EXFUN (compiler_lookup_trap, (SCHEME_OBJECT)),
  2890.   EXFUN (compiler_safe_lookup_trap, (SCHEME_OBJECT)),
  2891.   EXFUN (compiler_unassigned_p_trap, (SCHEME_OBJECT)),
  2892.   EXFUN (compiler_assignment_trap, (SCHEME_OBJECT, SCHEME_OBJECT));
  2893.  
  2894. long
  2895. DEFUN (compiler_lookup_trap, (extension), SCHEME_OBJECT extension)
  2896. {
  2897.   return (compiler_reference_trap (extension,
  2898.                    TRAP_REFERENCES_LOOKUP,
  2899.                    deep_lookup_end));
  2900. }
  2901.  
  2902. long
  2903. DEFUN (compiler_safe_lookup_trap, (extension), SCHEME_OBJECT extension)
  2904. {
  2905.   return (safe_reference_transform (compiler_lookup_trap (extension)));
  2906. }
  2907.  
  2908. long
  2909. DEFUN (compiler_unassigned_p_trap, (extension), SCHEME_OBJECT extension)
  2910. {
  2911.   return (unassigned_p_transform (compiler_lookup_trap (extension)));
  2912. }
  2913.  
  2914. long
  2915. DEFUN (compiler_assignment_trap, (extension, value),
  2916.        SCHEME_OBJECT extension
  2917.        AND SCHEME_OBJECT value)
  2918. {
  2919.   saved_compiler_assignment_value = value;
  2920.   return (compiler_reference_trap (extension,
  2921.                    TRAP_REFERENCES_ASSIGNMENT,
  2922.                    compiler_assignment_end));
  2923. }
  2924.